accelerate 1.2.0.1 → 1.3.0.0

raw patch · 171 files changed

+23019/−23127 lines, 171 filesdep +prettyprinterdep +prettyprinter-ansi-terminaldep +primitivedep −ansi-wl-pprintdep −constraintsdep −th-lift-instancesdep ~basedep ~halfdep ~textbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: prettyprinter, prettyprinter-ansi-terminal, primitive

Dependencies removed: ansi-wl-pprint, constraints, th-lift-instances

Dependency ranges changed: base, half, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +60/−0
• LICENSE +3/−3
• README.md +66/−25
• accelerate.cabal +138/−122
• cbits/atomic.c +2/−2
• cbits/clock.c +32/−9
• cbits/flags.c +334/−3
• cbits/flags.h +52/−0
• cbits/flags.inc +0/−336
• cbits/flags_debug.c +0/−13
• cbits/monitoring.c +133/−3
• cbits/monitoring.inc +0/−141
• cbits/monitoring_debug.c +0/−13
• images/accelerate-logo-text-v.png binary
• src/Data/Array/Accelerate.hs +141/−37
• src/Data/Array/Accelerate/AST.hs +1418/−1929
• src/Data/Array/Accelerate/AST/Environment.hs +90/−0
• src/Data/Array/Accelerate/AST/Idx.hs +44/−0
• src/Data/Array/Accelerate/AST/LeftHandSide.hs +62/−0
• src/Data/Array/Accelerate/AST/Var.hs +44/−0
• src/Data/Array/Accelerate/Analysis/Hash.hs +257/−306
• src/Data/Array/Accelerate/Analysis/Hash/TH.hs +2/−2
• src/Data/Array/Accelerate/Analysis/Match.hs +346/−454
• src/Data/Array/Accelerate/Analysis/Shape.hs +0/−124
• src/Data/Array/Accelerate/Analysis/Stencil.hs +0/−91
• src/Data/Array/Accelerate/Analysis/Type.hs +0/−222
• src/Data/Array/Accelerate/Array/Data.hs +392/−1035
• src/Data/Array/Accelerate/Array/Lifted.hs +0/−283
• src/Data/Array/Accelerate/Array/Remote.hs +6/−7
• src/Data/Array/Accelerate/Array/Remote/Class.hs +12/−19
• src/Data/Array/Accelerate/Array/Remote/LRU.hs +127/−105
• src/Data/Array/Accelerate/Array/Remote/Nursery.hs +6/−9
• src/Data/Array/Accelerate/Array/Remote/Table.hs +170/−232
• src/Data/Array/Accelerate/Array/Representation.hs +0/−235
• src/Data/Array/Accelerate/Array/Sugar.hs +0/−1381
• src/Data/Array/Accelerate/Array/Unique.hs +55/−15
• src/Data/Array/Accelerate/Async.hs +2/−2
• src/Data/Array/Accelerate/Classes.hs +4/−4
• src/Data/Array/Accelerate/Classes/Bounded.hs +51/−101
• src/Data/Array/Accelerate/Classes/Enum.hs +55/−49
• src/Data/Array/Accelerate/Classes/Eq.hs +140/−242
• src/Data/Array/Accelerate/Classes/Floating.hs +6/−4
• src/Data/Array/Accelerate/Classes/Fractional.hs +7/−6
• src/Data/Array/Accelerate/Classes/FromIntegral.hs +5/−12
• src/Data/Array/Accelerate/Classes/Integral.hs +7/−4
• src/Data/Array/Accelerate/Classes/Num.hs +8/−8
• src/Data/Array/Accelerate/Classes/Ord.hs +163/−452
• src/Data/Array/Accelerate/Classes/Rational.hs +97/−0
• src/Data/Array/Accelerate/Classes/Real.hs +2/−2
• src/Data/Array/Accelerate/Classes/RealFloat.hs +81/−78
• src/Data/Array/Accelerate/Classes/RealFloat.hs-boot +67/−0
• src/Data/Array/Accelerate/Classes/RealFrac.hs +150/−52
• src/Data/Array/Accelerate/Classes/RealFrac.hs-boot +24/−0
• src/Data/Array/Accelerate/Classes/ToFloating.hs +7/−15
• src/Data/Array/Accelerate/Data/Bits.hs +167/−145
• src/Data/Array/Accelerate/Data/Complex.hs +200/−135
• src/Data/Array/Accelerate/Data/Either.hs +44/−153
• src/Data/Array/Accelerate/Data/Fold.hs +12/−5
• src/Data/Array/Accelerate/Data/Functor.hs +5/−11
• src/Data/Array/Accelerate/Data/Maybe.hs +48/−164
• src/Data/Array/Accelerate/Data/Monoid.hs +41/−112
• src/Data/Array/Accelerate/Data/Ratio.hs +141/−0
• src/Data/Array/Accelerate/Data/Semigroup.hs +25/−39
• src/Data/Array/Accelerate/Debug.hs +3/−20
• src/Data/Array/Accelerate/Debug/Clock.hs +27/−0
• src/Data/Array/Accelerate/Debug/Flags.hs +138/−79
• src/Data/Array/Accelerate/Debug/Monitoring.hs +18/−8
• src/Data/Array/Accelerate/Debug/Stats.hs +57/−27
• src/Data/Array/Accelerate/Debug/Timed.hs +24/−42
• src/Data/Array/Accelerate/Debug/Trace.hs +3/−7
• src/Data/Array/Accelerate/Error.hs +67/−82
• src/Data/Array/Accelerate/Interpreter.hs +1773/−2012
• src/Data/Array/Accelerate/Language.hs +250/−188
• src/Data/Array/Accelerate/Lifetime.hs +3/−8
• src/Data/Array/Accelerate/Lift.hs +128/−519
• src/Data/Array/Accelerate/Orphans.hs +49/−0
• src/Data/Array/Accelerate/Pattern.hs +286/−0
• src/Data/Array/Accelerate/Pattern/Bool.hs +26/−0
• src/Data/Array/Accelerate/Pattern/Either.hs +26/−0
• src/Data/Array/Accelerate/Pattern/Maybe.hs +26/−0
• src/Data/Array/Accelerate/Pattern/Ordering.hs +26/−0
• src/Data/Array/Accelerate/Pattern/TH.hs +456/−0
• src/Data/Array/Accelerate/Prelude.hs +517/−294
• src/Data/Array/Accelerate/Pretty.hs +139/−61
• src/Data/Array/Accelerate/Pretty/Graphviz.hs +209/−223
• src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs +7/−5
• src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs +50/−50
• src/Data/Array/Accelerate/Pretty/Print.hs +733/−630
• src/Data/Array/Accelerate/Product.hs +0/−227
• src/Data/Array/Accelerate/Representation/Array.hs +261/−0
• src/Data/Array/Accelerate/Representation/Elt.hs +160/−0
• src/Data/Array/Accelerate/Representation/Shape.hs +196/−0
• src/Data/Array/Accelerate/Representation/Slice.hs +108/−0
• src/Data/Array/Accelerate/Representation/Stencil.hs +161/−0
• src/Data/Array/Accelerate/Representation/Tag.hs +68/−0
• src/Data/Array/Accelerate/Representation/Type.hs +118/−0
• src/Data/Array/Accelerate/Representation/Vec.hs +95/−0
• src/Data/Array/Accelerate/Smart.hs +1352/−2310
• src/Data/Array/Accelerate/Sugar/Array.hs +319/−0
• src/Data/Array/Accelerate/Sugar/Elt.hs +415/−0
• src/Data/Array/Accelerate/Sugar/Foreign.hs +37/−0
• src/Data/Array/Accelerate/Sugar/Shape.hs +364/−0
• src/Data/Array/Accelerate/Sugar/Vec.hs +39/−0
• src/Data/Array/Accelerate/Test/NoFib.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Base.hs +33/−13
• src/Data/Array/Accelerate/Test/NoFib/Config.hs +18/−17
• src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs +20/−20
• src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs +20/−20
• src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs +20/−19
• src/Data/Array/Accelerate/Test/NoFib/Issues.hs +14/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs +5/−7
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs +3/−3
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs +5/−5
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs +3/−3
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs +21/−20
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +99/−0
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs +12/−12
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs +12/−12
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs +59/−0
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs +90/−0
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs +37/−0
• src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs +3/−3
• src/Data/Array/Accelerate/Test/NoFib/Prelude.hs +5/−2
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs +24/−23
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs +27/−26
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs +44/−44
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +53/−74
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +44/−41
• src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +236/−0
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs +203/−203
• src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs +36/−37
• src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs +56/−55
• src/Data/Array/Accelerate/Test/NoFib/Sharing.hs +7/−7
• src/Data/Array/Accelerate/Test/NoFib/Spectral.hs +2/−2
• src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs +11/−11
• src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +22/−23
• src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs +12/−13
• src/Data/Array/Accelerate/Test/Similar.hs +6/−4
• src/Data/Array/Accelerate/Trafo.hs +42/−143
• src/Data/Array/Accelerate/Trafo/Algebra.hs +280/−330
• src/Data/Array/Accelerate/Trafo/Base.hs +0/−442
• src/Data/Array/Accelerate/Trafo/Config.hs +49/−0
• src/Data/Array/Accelerate/Trafo/Delayed.hs +126/−0
• src/Data/Array/Accelerate/Trafo/Environment.hs +163/−0
• src/Data/Array/Accelerate/Trafo/Fusion.hs +1733/−1566
• src/Data/Array/Accelerate/Trafo/LetSplit.hs +75/−0
• src/Data/Array/Accelerate/Trafo/Rewrite.hs +0/−152
• src/Data/Array/Accelerate/Trafo/Sharing.hs +3105/−2933
• src/Data/Array/Accelerate/Trafo/Shrink.hs +374/−214
• src/Data/Array/Accelerate/Trafo/Simplify.hs +205/−283
• src/Data/Array/Accelerate/Trafo/Substitution.hs +451/−247
• src/Data/Array/Accelerate/Trafo/Var.hs +78/−0
• src/Data/Array/Accelerate/Type.hs +252/−314
• src/Data/Array/Accelerate/Unsafe.hs +12/−9
• src/Data/Atomic.hs +11/−2
• src/Data/BitSet.hs +162/−0
• src/Data/Primitive/Vec.hs +290/−0
• src/Language/Haskell/TH/Extra.hs +36/−0
• test/doctest/Main.hs +2/−2
• test/nofib/Main.hs +2/−2

@@ -6,6 +6,59 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.3.0.0] - 2020-08-26+### Added+  * Instances of `Elt` are now derivable via `Generic` for simple (Haskell'98)+    product _and_ sum data types.+  * Pattern synonyms for manipulating custom product and sum types can now be+    created; see `Pattern`, `mkPattern`+  * Added pattern synonyms for accessing tuples and indices, as an alternative+    to `lift` and `unlift`.+  * Support for pattern matching in the embedded language; see `match`++### Changed+  * The `stencil` functions now support fusion. Note however that the source+    (delayed) array will be evaluated at _every_ access to the stencil pattern;+    if the delayed function is expensive, you may wish to explicitly `compute`+    the source array first, matching the old behaviour.+  * Removed `Slice` constraint from some indexing operations+  * Improve fusion for `zipWith*` ([#453])+  * The indexing function to `permute` now returns a `Maybe` type ([#87])++  * (internal) Visible type applications are used instead of `Proxy` types+  * (internal) `EltR` is now a class-associated type of `Elt`+  * (internal) `GArrayData` has been simplified+  * (internal) SIMD representation has been improved and generalised+  * (internal) Internal refactoring ([#449], [#455], [#457], [#460])++  * Probably many others I have forgotten about++### Removed+  * Drop support for GHC-7.10 .. 8.4.++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Joshua Meredith (@JoshMeredith)+  * Ivo Gabe de Wolff (@ivogabe)+  * David van Balen (@dpvanbalen)+  * Jaro Reinders (@noughtmare)+  * Alex Lang (@alang9)+  * Paul Wilson (@status_failed)+  * @lennonhill+  * Travis Whitaker (@TravisWhitaker)+  * Roger Bosman (@rogerbosman)+  * Robbert van der Helm (@robbert-vdh)+  * Sam (@sam-340453)+  * Lars van den Haak (@sakehl)+  * Rinat Striungis (@Haskell-mouse)+  * Viktor Kronvall (@considerate)+  * Tom Smeding (@tomsmeding)+  * Ryan Scott (@RyanGlScott)++ ## [1.2.0.1] - 2018-10-06 ### Fixed   * Build fix for ghc-8.6@@ -133,6 +186,7 @@   * Initial release of the CUDA backend  +[1.3.0.0]:          https://github.com/AccelerateHS/accelerate/compare/v1.2.0.1...v1.3.0.0 [1.2.0.1]:          https://github.com/AccelerateHS/accelerate/compare/v1.2.0.0...v1.2.0.1 [1.2.0.0]:          https://github.com/AccelerateHS/accelerate/compare/v1.1.0.0...v1.2.0.0 [1.1.1.0]:          https://github.com/AccelerateHS/accelerate/compare/v1.1.0.0...v1.1.1.0@@ -148,6 +202,12 @@ [0.9.0.0]:          https://github.com/AccelerateHS/accelerate/compare/0_8_1_0...0.9.0.0 [0.7.1.0]:          https://github.com/AccelerateHS/accelerate/compare/0_6_0_0...0_7_1_0 +[#87]:              https://github.com/AccelerateHS/accelerate/issues/87 [#340]:             https://github.com/AccelerateHS/accelerate/issues/340 [#390]:             https://github.com/AccelerateHS/accelerate/issues/390+[#453]:             https://github.com/AccelerateHS/accelerate/pull/453+[#449]:             https://github.com/AccelerateHS/accelerate/pull/449+[#455]:             https://github.com/AccelerateHS/accelerate/pull/455+[#457]:             https://github.com/AccelerateHS/accelerate/pull/457+[#460]:             https://github.com/AccelerateHS/accelerate/pull/460 

@@ -1,4 +1,4 @@-Copyright (c) [2007..2017] The Accelerate Team.  All rights reserved.+Copyright (c) [2007..2020] The Accelerate Team.  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:@@ -7,8 +7,8 @@     * Redistributions in binary form must reproduce the above copyright       notice, this list of conditions and the following disclaimer in the       documentation and/or other materials provided with the distribution.-    * Neither the names of the contributors nor of their affiliations may -      be used to endorse or promote products derived from this software +    * Neither the names of the contributors nor of their affiliations may+      be used to endorse or promote products derived from this software       without specific prior written permission.  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY

@@ -1,13 +1,16 @@-An Embedded Language for Accelerated Array Computations-=======================================================+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/> -[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate)-[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate)+# High-performance parallel arrays for Haskell++[![GitHub CI](https://github.com/tmcdonell/accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate/actions)+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby)+<br> [![Stackage LTS](https://stackage.org/package/accelerate/badge/lts)](https://stackage.org/lts/package/accelerate) [![Stackage Nightly](https://stackage.org/package/accelerate/badge/nightly)](https://stackage.org/nightly/package/accelerate) [![Hackage](https://img.shields.io/hackage/v/accelerate.svg)](https://hackage.haskell.org/package/accelerate)-[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +</div>  `Data.Array.Accelerate` defines an embedded language of array computations for high-performance computing in Haskell. Computations on multi-dimensional, regular arrays are expressed in the form of parameterised collective operations (such as maps, reductions, and permutations). These computations are online-compiled and executed on a range of architectures. @@ -17,6 +20,7 @@  * [Optimising Purely Functional GPU Programs][MCKL13] ([slides][MCKL13-slides])  * [Embedding Foreign Code][CMCK14]  * [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15] ([slides][MCGN15-slides]) ([video][MCGN15-video])+ * [Streaming Irregular Arrays][CMCK17] ([video][CMCK17-video])  There are also slides from some fairly recent presentations: @@ -37,6 +41,7 @@   - [Requirements](#requirements)   - [Documentation](#documentation)   - [Examples](#examples)+  - [Who are we?](#who-are-we)   - [Mailing list and contacts](#mailing-list-and-contacts)   - [Citing Accelerate](#citing-accelerate)   - [What's missing?](#whats-missing)@@ -106,8 +111,8 @@   * A cellular automata simulation   * A "password recovery" tool, for dictionary lookup of MD5 hashes -[![Mandelbrot](http://i.imgur.com/5Tbsp1j.jpg "accelerate-mandelbrot")](http://i.imgur.com/RgXRqsc.jpg)-[![Raytracer](http://i.imgur.com/7ohhKm9.jpg "accelerate-ray")](http://i.imgur.com/ZNEGEJK.jpg)+[![Mandelbrot](https://i.imgur.com/5Tbsp1j.jpg "accelerate-mandelbrot")](https://i.imgur.com/RgXRqsc.jpg)+[![Raytracer](https://i.imgur.com/7ohhKm9.jpg "accelerate-ray")](https://i.imgur.com/ZNEGEJK.jpg)  <!-- <video width=400 height=300 controls=false autoplay loop>@@ -120,12 +125,7 @@  [LULESH-accelerate][lulesh-accelerate] is in implementation of the Livermore Unstructured Lagrangian Explicit Shock Hydrodynamics (LULESH) mini-app. [LULESH][LULESH] represents a typical hydrodynamics code such as [ALE3D][ALE3D], but is a highly simplified application, hard-coded to solve the Sedov blast problem on an unstructured hexahedron mesh. -![LULESH mesh](https://codesign.llnl.gov/images/sedov-3d-LLNL.png)---### Λ ○ λ (Lol)--Λ ○ λ ([Lol][lol]) is a general-purpose library for ring-based lattice cryptography. Lol has applications in, for example, symmetric-key somewhat-homomorphic encryption schemes. The [lol-accelerate][lol-accelerate] package provides an Accelerate backend for Lol.+![LULESH mesh](https://i.imgur.com/bIkODKd.jpg)   ### Additional examples@@ -133,27 +133,50 @@ Accelerate users have also built some substantial applications of their own. Please feel free to add your own examples! +  * Jonathan Fraser, [GPUVAC](https://github.com/GeneralFusion/gpuvac): An explicit advection magnetohydrodynamics simulation+  * David van Balen, [Sudokus](https://github.com/dpvanbalen/Sudokus): A sudoku solver+  * Trevor L. McDonell, [lol-accelerate][lol-accelerate]: A backend to the Λ ○ λ ([Lol][lol]) library for ring-based lattice cryptography   * Henning Thielemann, [patch-image](http://hackage.haskell.org/package/patch-image): Combine a collage of overlapping images   * apunktbau, [bildpunkt](https://github.com/abau/bildpunkt): A ray-marching distance field renderer   * klarh, [hasdy](https://github.com/klarh/hasdy): Molecular dynamics in Haskell using Accelerate   * Alexandros Gremm used Accelerate as part of the [2014 CSCS summer school](http://user.cscs.ch/blog/2014/cscs_usi_summer_school_2014_30_june_10_july_2014_in_serpiano_tessin/index.html) ([code](https://github.com/agremm/cscs))  +Who are we?+-----------++The Accelerate team (past and present) consists of:++  * Manuel M T Chakravarty ([@mchakravarty])  <!-- 2008..2017? -->+  * Gabriele Keller ([@gckeller])             <!-- 2008..     -->+  * Trevor L. McDonell ([@tmcdonell])         <!-- 2009..     -->+  * Robert Clifton-Everest ([@robeverest])    <!-- 2013..     -->+  * Frederik M. Madsen ([@fmma])              <!-- 2014       -->+  * Ryan R. Newton ([@rrnewton])              <!-- 2012..2013 -->+  * Joshua Meredith ([@JoshMeredith])         <!-- 2018..     -->+  * Ben Lever ([@blever])                     <!-- 2010..2011 -->+  * Sean Seefried ([@sseefried])              <!-- 2010..2011 -->+  * Ivo Gabe de Wolff ([@ivogabe])            <!-- 2019..     -->++The maintainer and principal developer of Accelerate is Trevor L.+McDonell <trevor.mcdonell@gmail.com>.++ Mailing list and contacts -------------------------    * Mailing list: [`accelerate-haskell@googlegroups.com`](mailto:accelerate-haskell@googlegroups.com) (discussions on both use and development are welcome)-  * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group].-  * Bug reports and issues tracking: [GitHub project page][Issues].--The maintainers of Accelerate are Manuel M T Chakravarty <chak@cse.unsw.edu.au> and Trevor L McDonell <tmcdonell@cse.unsw.edu.au>.+  * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group]+  * Bug reports and issues tracking: [GitHub project page][Issues]+  * Chat with us on [gitter](https://gitter.im/AccelerateHS/Lobby)   Citing Accelerate -----------------  If you use Accelerate for academic research, you are encouraged (though not-required) to cite the following papers ([BibTeX](http://www.cse.unsw.edu.au/~tmcdonell/papers/accelerate.bib)):+required) to cite the following papers:+<!-- ([BibTeX](http://www.cse.unsw.edu.au/~tmcdonell/papers/accelerate.bib)): -->    * Manuel M. T. Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell, and Vinod Grover.     [Accelerating Haskell Array Codes with Multicore GPUs][CKLM+11].@@ -171,6 +194,11 @@     [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15].     In _Haskell '15: The 8th ACM SIGPLAN Symposium on Haskell_, ACM, 2015. +  * Robert Clifton-Everest, Trevor L. McDonell, Manuel M. T. Chakravarty, and Gabriele Keller.+    [Streaming Irregular Arrays][CMCK17].+    In Haskell '17: The 10th ACM SIGPLAN Symposium on Haskell, ACM, 2017.++ Accelerate is primarily developed by academics, so citations matter a lot to us. As an added benefit, you increase Accelerate's exposure and potential user (and developer!) base, which is a benefit to all users of Accelerate. Thanks in advance!@@ -182,17 +210,29 @@ Here is a list of features that are currently missing:   * Preliminary API (parts of the API may still change in subsequent releases)-+ * Many more features... contact us! +  [@mchakravarty]:              https://github.com/mchakravarty+  [@gckeller]:                  https://github.com/gckeller+  [@tmcdonell]:                 https://github.com/tmcdonell+  [@robeverest]:                https://github.com/robeverest+  [@fmma]:                      https://github.com/fmma+  [@rrnewton]:                  https://github.com/rrnewton+  [@JoshMeredith]:              https://github.com/JoshMeredith+  [@blever]:                    https://github.com/blever+  [@sseefried]:                 https://github.com/sseefried+  [@ivogabe]:                   https://github.com/ivogabe -  [CKLM+11]:                    http://www.cse.unsw.edu.au/~chak/papers/CKLM+11.html-  [MCKL13]:                     http://www.cse.unsw.edu.au/~chak/papers/MCKL13.html+  [CKLM+11]:                    https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-cuda-damp2011.pdf+  [MCKL13]:                     https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-optim-icfp2013.pdf   [MCKL13-slides]:              https://speakerdeck.com/tmcdonell/optimising-purely-functional-gpu-programs-  [CMCK14]:                     http://www.cse.unsw.edu.au/~chak/papers/CMCK14.html-  [MCGN15]:                     http://www.cse.unsw.edu.au/~chak/papers/MCGN15.html+  [CMCK14]:                     https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-ffi-padl2014.pdf+  [MCGN15]:                     https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-llvm-haskell2015.pdf   [MCGN15-slides]:              https://speakerdeck.com/tmcdonell/type-safe-runtime-code-generation-accelerate-to-llvm   [MCGN15-video]:               https://www.youtube.com/watch?v=snXhXA5noVc   [HIW'09]:                     https://wiki.haskell.org/HaskellImplementorsWorkshop+  [CMCK17]:                     https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-seq2-haskell2017.pdf+  [CMCK17-video]:               https://www.youtube.com/watch?v=QIWSqp7AaNo   [Mar13]:                      http://chimera.labs.oreilly.com/books/1230000000929   [Embedded]:                   https://speakerdeck.com/mchakravarty/embedded-languages-for-high-performance-computing-in-haskell   [Hackage]:                    http://hackage.haskell.org/package/accelerate@@ -215,7 +255,8 @@   [Wiki]:                       https://github.com/AccelerateHS/accelerate/wiki   [Issues]:                     https://github.com/AccelerateHS/accelerate/issues   [Google-Group]:               http://groups.google.com/group/accelerate-haskell-  [HOAS-conv]:                  http://www.cse.unsw.edu.au/~chak/haskell/term-conv/+  [HOAS-conv]:                  https://github.com/mchakravarty/hoas-conv+  <!-- [HOAS-conv]:                  https://web.archive.org/web/20180805092417/http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ -->   [repa]:                       http://hackage.haskell.org/package/repa   [wiki-cc]:                    https://en.wikipedia.org/wiki/CUDA#Supported_GPUs   [YLJ13-video]:                http://youtu.be/ARqE4yT2Z0o@@ -226,7 +267,7 @@   [wiki-nbody]:                 https://en.wikipedia.org/wiki/N-body   [wiki-raytracing]:            https://en.wikipedia.org/wiki/Ray_tracing   [wiki-pagerank]:              https://en.wikipedia.org/wiki/Pagerank-  [Trevor-thesis]:              http://www.cse.unsw.edu.au/~tmcdonell/papers/TrevorMcDonell_PhD_submission.pdf+  [Trevor-thesis]:              https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/TrevorMcDonell_PhD_Thesis.pdf   [colour-accelerate]:          https://github.com/tmcdonell/colour-accelerate   [gloss]:                      https://hackage.haskell.org/package/gloss   [gloss-accelerate]:           https://github.com/tmcdonell/gloss-accelerate

@@ -1,12 +1,12 @@-Name:                   accelerate-Version:                1.2.0.1-Cabal-version:          >= 1.18-Tested-with:            GHC >= 7.8-Build-type:             Custom+name:                   accelerate+version:                1.3.0.0+cabal-version:          1.18+tested-with:            GHC >= 8.6+build-type:             Custom -Synopsis:               An embedded language for accelerated array processing+synopsis:               An embedded language for accelerated array processing -Description:+description:   @Data.Array.Accelerate@ defines an embedded array language for computations   for high-performance computing in Haskell. Computations on multi-dimensional,   regular arrays are expressed in the form of parameterised collective@@ -41,18 +41,25 @@       greater. See the following table for supported GPUs:       <http://en.wikipedia.org/wiki/CUDA#Supported_GPUs>   .-    * @accelerate-examples@: Computational kernels and applications showcasing-      the use of Accelerate as well as a regression test suite, supporting-      function and performance testing.+    * @accelerate-examples@: Computational kernels and applications+      demonstrating the use of Accelerate.   .-    * @accelerate-io@: Fast conversions between Accelerate arrays and other-      array formats (including vector and repa).+    * @accelerate-io*@: Fast conversions between Accelerate arrays and other+      array and data formats.   .     * @accelerate-fft@: Discrete Fourier transforms, with FFI bindings to       optimised implementations.   .+    * @accelerate-blas@: Numeric linear algebra, with FFI bindings to optimised+      implementations.+  .     * @accelerate-bignum@: Fixed-width large integer arithmetic.   .+    * @containers-accelerate@: Container types for use with Accelerate.+  .+    * @hashable-accelerate@: Class for types which can be converted to a hash+      value.+  .     * @colour-accelerate@: Colour representations in Accelerate (RGB, sRGB, HSV,       and HSL).   .@@ -77,7 +84,7 @@   .     * An implementation of the Canny edge detection algorithm   .-    * An interactive Mandelbrot set generator+    * Interactive Mandelbrot and Julia set generators   .     * A particle-based simulation of stable fluid flows   .@@ -99,6 +106,8 @@   .   [/Mailing list and contacts/]   .+    * Gitter chat: <https://gitter.im/AccelerateHS/Lobby>+  .     * Mailing list: <accelerate-haskell@googlegroups.com> (discussion of both       use and development welcome).   .@@ -109,40 +118,34 @@       <https://github.com/AccelerateHS/accelerate/issues>   . -License:                BSD3-License-file:           LICENSE-Author:                 Manuel M T Chakravarty,-                        Robert Clifton-Everest,-                        Gabriele Keller,-                        Ben Lever,-                        Trevor L. McDonell,-                        Ryan Newtown,-                        Sean Seefried-Maintainer:             Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>-Homepage:               https://github.com/AccelerateHS/accelerate/-Bug-reports:            https://github.com/AccelerateHS/accelerate/issues+license:                BSD3+license-file:           LICENSE+author:                 The Accelerate Team+maintainer:             Trevor L. McDonell <trevor.mcdonell@gmail.com>+homepage:               https://github.com/AccelerateHS/accelerate/+bug-reports:            https://github.com/AccelerateHS/accelerate/issues -Category:               Compilers/Interpreters, Concurrency, Data, Parallelism-Stability:              Experimental+category:               Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism+stability:              Experimental -Extra-source-files:+extra-source-files:     README.md     CHANGELOG.md-    cbits/flags.inc-    cbits/monitoring.inc+    cbits/*.c+    cbits/*.h -Extra-doc-files:+extra-doc-files:     images/*.png  custom-setup   setup-depends:-      base              >= 4.7+      base              >= 4.10     , Cabal     , cabal-doctest     >= 1.0 -Flag debug-  Default:              False-  Description:+flag debug+  default:              False+  description:     Enable debug tracing messages. The following options are read from the     environment variable @ACCELERATE_FLAGS@, and via the command-line as:     .@@ -161,6 +164,8 @@     .       * @simplify@: Enable program simplification phase (True).     .+      * @inplace@: Enable in-place array updates (True).+    .       * @flush-cache@: Clear any persistent caches on program startup (False).     .       * @force-recomp@: Force recompilation of array programs (False).@@ -168,6 +173,9 @@       * @fast-math@: Allow algebraically equivalent transformations which may         change floating point results (e.g., reassociate) (True).     .+      * @fast-permute-const@: Allow non-atomic `permute const` for product types+        (True).+    .     The following options control debug message output, and are enabled with     @-d\<flag\>@.     .@@ -212,9 +220,9 @@       * @dump-sched@: Print information related to execution scheduling.     . -Flag ekg-  Default:              False-  Description:+flag ekg+  default:              False+  description:     Enable hooks for monitoring the running application using EKG. Implies     @debug@ mode. In order to view the metrics, your application will need to     call @Data.Array.Accelerate.Debug.beginMonitoring@ before running any@@ -248,57 +256,56 @@     > -with-rtsopts=-T     . -Flag bounds-checks-  Description:          Enable bounds checking-  Default:              True+flag bounds-checks+  description:          Enable bounds checking+  default:              True -Flag unsafe-checks-  Description:          Enable bounds checking in unsafe operations-  Default:              False+flag unsafe-checks+  description:          Enable bounds checking in unsafe operations+  default:              False -Flag internal-checks-  Description:          Enable internal consistency checks-  Default:              False+flag internal-checks+  description:          Enable internal consistency checks+  default:              False -Flag nofib-  Default:              True-  Description:-    You can disable building the nofib test suite with this flag. Disabling this-    is an unsupported configuration, but is useful for accelerating builds.+-- Enabling this drastically increases build times+-- See: https://gitlab.haskell.org/ghc/ghc/issues/15751+flag nofib+  default:              False+  description:          Build the nofib test suite (required for backend testing) -Library-  Build-depends:-          base                          >= 4.7 && < 4.13+library+  build-depends:+          base                          >= 4.12 && < 4.15         , ansi-terminal                 >= 0.6.2-        , ansi-wl-pprint                >= 0.6         , base-orphans                  >= 0.3         , bytestring                    >= 0.10.2         , containers                    >= 0.3-        , constraints                   >= 0.9         , cryptonite                    >= 0.21         , deepseq                       >= 1.3         , directory                     >= 1.0         , exceptions                    >= 0.6         , filepath                      >= 1.0         , ghc-prim-        , half                          >= 0.2+        , half                          >= 0.3         , hashable                      >= 1.1         , hashtables                    >= 1.2.3         , hedgehog                      >= 0.5         , lens                          >= 4.0         , mtl                           >= 2.0+        , prettyprinter                 >= 1.2+        , prettyprinter-ansi-terminal   >= 1.0+        , primitive                     >= 0.6.4         , tasty                         >= 0.11-        , tasty-expected-failure        >= 0.11-        , tasty-hedgehog                >= 0.1-        , tasty-hunit                   >= 0.9         , template-haskell         , terminal-size                 >= 0.3+        , text                          >= 1.2         , transformers                  >= 0.3         , unique         , unordered-containers          >= 0.2         , vector                        >= 0.10 -  Exposed-modules:+  exposed-modules:         -- The core language and reference implementation         Data.Array.Accelerate         Data.Array.Accelerate.Interpreter@@ -311,41 +318,60 @@         Data.Array.Accelerate.Data.Functor         Data.Array.Accelerate.Data.Maybe         Data.Array.Accelerate.Data.Monoid+        Data.Array.Accelerate.Data.Ratio         Data.Array.Accelerate.Unsafe          -- For backend development (hidden)         Data.Array.Accelerate.AST+        Data.Array.Accelerate.AST.Environment+        Data.Array.Accelerate.AST.Idx+        Data.Array.Accelerate.AST.LeftHandSide+        Data.Array.Accelerate.AST.Var         Data.Array.Accelerate.Analysis.Hash         Data.Array.Accelerate.Analysis.Match-        Data.Array.Accelerate.Analysis.Shape-        Data.Array.Accelerate.Analysis.Stencil-        Data.Array.Accelerate.Analysis.Type         Data.Array.Accelerate.Array.Data         Data.Array.Accelerate.Array.Remote         Data.Array.Accelerate.Array.Remote.Class         Data.Array.Accelerate.Array.Remote.LRU         Data.Array.Accelerate.Array.Remote.Table-        Data.Array.Accelerate.Array.Representation-        Data.Array.Accelerate.Array.Sugar         Data.Array.Accelerate.Array.Unique         Data.Array.Accelerate.Async         Data.Array.Accelerate.Debug         Data.Array.Accelerate.Error         Data.Array.Accelerate.Lifetime         Data.Array.Accelerate.Pretty-        Data.Array.Accelerate.Product+        Data.Array.Accelerate.Representation.Array+        Data.Array.Accelerate.Representation.Elt+        Data.Array.Accelerate.Representation.Shape+        Data.Array.Accelerate.Representation.Slice+        Data.Array.Accelerate.Representation.Stencil+        Data.Array.Accelerate.Representation.Tag+        Data.Array.Accelerate.Representation.Type+        Data.Array.Accelerate.Representation.Vec         Data.Array.Accelerate.Smart+        Data.Array.Accelerate.Sugar.Array+        Data.Array.Accelerate.Sugar.Elt+        Data.Array.Accelerate.Sugar.Foreign+        Data.Array.Accelerate.Sugar.Shape+        Data.Array.Accelerate.Sugar.Vec         Data.Array.Accelerate.Trafo+        Data.Array.Accelerate.Trafo.Config+        Data.Array.Accelerate.Trafo.Delayed+        Data.Array.Accelerate.Trafo.Fusion+        Data.Array.Accelerate.Trafo.Sharing+        Data.Array.Accelerate.Trafo.Substitution         Data.Array.Accelerate.Type          -- For testing         Data.Array.Accelerate.Test.NoFib         Data.Array.Accelerate.Test.Similar -  Other-modules:-        Data.Atomic+        -- Other+        Data.BitSet+        Data.Primitive.Vec++  other-modules:         Data.Array.Accelerate.Analysis.Hash.TH-        Data.Array.Accelerate.Array.Lifted         Data.Array.Accelerate.Array.Remote.Nursery         Data.Array.Accelerate.Classes         Data.Array.Accelerate.Classes.Bounded@@ -357,10 +383,12 @@         Data.Array.Accelerate.Classes.Integral         Data.Array.Accelerate.Classes.Num         Data.Array.Accelerate.Classes.Ord+        Data.Array.Accelerate.Classes.Rational         Data.Array.Accelerate.Classes.Real         Data.Array.Accelerate.Classes.RealFloat         Data.Array.Accelerate.Classes.RealFrac         Data.Array.Accelerate.Classes.ToFloating+        Data.Array.Accelerate.Debug.Clock         Data.Array.Accelerate.Debug.Flags         Data.Array.Accelerate.Debug.Monitoring         Data.Array.Accelerate.Debug.Stats@@ -368,27 +396,40 @@         Data.Array.Accelerate.Debug.Trace         Data.Array.Accelerate.Language         Data.Array.Accelerate.Lift+        Data.Array.Accelerate.Orphans+        Data.Array.Accelerate.Pattern+        Data.Array.Accelerate.Pattern.Bool+        Data.Array.Accelerate.Pattern.Either+        Data.Array.Accelerate.Pattern.Maybe+        Data.Array.Accelerate.Pattern.Ordering+        Data.Array.Accelerate.Pattern.TH         Data.Array.Accelerate.Prelude         Data.Array.Accelerate.Pretty.Graphviz         Data.Array.Accelerate.Pretty.Graphviz.Monad         Data.Array.Accelerate.Pretty.Graphviz.Type         Data.Array.Accelerate.Pretty.Print         Data.Array.Accelerate.Trafo.Algebra-        Data.Array.Accelerate.Trafo.Base-        Data.Array.Accelerate.Trafo.Fusion-        Data.Array.Accelerate.Trafo.Rewrite-        Data.Array.Accelerate.Trafo.Sharing+        Data.Array.Accelerate.Trafo.Environment+        Data.Array.Accelerate.Trafo.LetSplit         Data.Array.Accelerate.Trafo.Shrink         Data.Array.Accelerate.Trafo.Simplify-        Data.Array.Accelerate.Trafo.Substitution+        Data.Array.Accelerate.Trafo.Var+        Data.Atomic++        -- Data.Array.Accelerate.Array.Lifted         -- Data.Array.Accelerate.Trafo.Vectorise          -- nofib test suite         Data.Array.Accelerate.Test.NoFib.Base         Data.Array.Accelerate.Test.NoFib.Config +        Language.Haskell.TH.Extra+   if flag(nofib)-    -- build-depends:+    build-depends:+          tasty-expected-failure        >= 0.11+        , tasty-hedgehog                >= 0.1+        , tasty-hunit                   >= 0.9     --     , pipes                         >= 4.1.6   -- #286      other-modules:@@ -396,6 +437,7 @@         Data.Array.Accelerate.Test.NoFib.Prelude         Data.Array.Accelerate.Test.NoFib.Prelude.Map         Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith+        Data.Array.Accelerate.Test.NoFib.Prelude.SIMD         Data.Array.Accelerate.Test.NoFib.Prelude.Fold         Data.Array.Accelerate.Test.NoFib.Prelude.Scan         Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute@@ -428,8 +470,13 @@         Data.Array.Accelerate.Test.NoFib.Issues.Issue287         Data.Array.Accelerate.Test.NoFib.Issues.Issue288         Data.Array.Accelerate.Test.NoFib.Issues.Issue362+        Data.Array.Accelerate.Test.NoFib.Issues.Issue364         Data.Array.Accelerate.Test.NoFib.Issues.Issue407         Data.Array.Accelerate.Test.NoFib.Issues.Issue409+        Data.Array.Accelerate.Test.NoFib.Issues.Issue436+        Data.Array.Accelerate.Test.NoFib.Issues.Issue437+        Data.Array.Accelerate.Test.NoFib.Issues.Issue439+   else     cpp-options:         -DACCELERATE_DISABLE_NOFIB@@ -451,19 +498,6 @@     cpp-options:         -DACCELERATE_DEBUG -    -- Weird handling of C files because Cabal is not recompile C files on-    -- changes to cc-options: <https://github.com/haskell/cabal/issues/4937>-    c-sources:-        cbits/atomic.c-        cbits/clock.c-        cbits/flags_debug.c-        cbits/monitoring_debug.c-  else-    c-sources:-        cbits/atomic.c-        cbits/flags.c-        cbits/monitoring.c-   if flag(ekg)     cpp-options:         -DACCELERATE_MONITORING@@ -500,30 +534,17 @@   ghc-options:         -O2         -Wall+        -Wcompat+        -Wmissed-specialisations+        -- -Wredundant-constraints+        -freduction-depth=100+        -fspec-constr-count=50         -funbox-strict-fields-        -fno-warn-name-shadowing    ghc-prof-options:         -caf-all         -auto-all -  if impl(ghc >= 7.0)-    ghc-options:-        -fspec-constr-count=25--  if impl(ghc == 7.*)-    ghc-options:-        -fcontext-stack=35--  if impl(ghc >= 8.0)-    ghc-options:-        -Wcompat-        -freduction-depth=35--  if impl(ghc < 7.10)-    build-depends:-          th-lift-instances             >= 0.1-   -- Don't add the extensions list here. Instead, place individual LANGUAGE   -- pragmas in the files that require a specific extension. This means the   -- project loads in GHCi, and avoids extension clashes.@@ -538,7 +559,7 @@   main-is:              Main.hs    build-depends:-          base                          >= 4.7+          base                          >= 4.10         , accelerate         , doctest                       >= 0.11 @@ -547,17 +568,9 @@         -threaded         -rtsopts -  -- older ghc does not support the dimension-specialised show instances for-  -- arrays, which the doctests use-  if impl(ghc < 7.10)-    buildable:          False--  -- doctest only supports a single x-doctest-options line-  if impl(ghc == 7.*)-    x-doctest-options:  -fspec-constr-count=25 -fcontext-stack=35--  if impl(ghc >= 8.0)-    x-doctest-options:  -fspec-constr-count=25 -freduction-depth=35+  x-doctest-options:+        -freduction-depth=100+        -fspec-constr-count=50   test-suite nofib-interpreter@@ -566,8 +579,11 @@   hs-source-dirs:       test/nofib   main-is:              Main.hs +  if !flag(nofib)+    buildable: False+   build-depends:-          base                          >= 4.7+          base                          >= 4.10         , accelerate    ghc-options:@@ -584,7 +600,7 @@  source-repository this   Type:                 git-  Tag:                  v1.2.0.1+  Tag:                  v1.3.0.0   Location:             git://github.com/AccelerateHS/accelerate.git  -- vim: nospell

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

@@ -1,9 +1,9 @@ /*  * Module      : Data.Array.Accelerate.Debug.Clock- * Copyright   : [2017] Trevor L. McDonell+ * Copyright   : [2017..2020] The Accelerate Team  * License     : BSD3  *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>  * Stability   : experimental  * Portability : non-portable (GHC extensions)  *@@ -26,16 +26,39 @@ #include <mach/clock.h> #include <mach/mach.h> -static void clock_darwin_gettime(clock_id_t clock, struct timespec *t)+static clock_serv_t __cclock;++/* constructors with priority execute before constructors without a priority+ * value.+ *+ * constructors with a lower [numeric] priority value are executed before+ * constructors with a higher [numeric] priority.+ *+ * constructor priority values [0,100] are reserved.+ */+__attribute__((constructor(101))) void initialise_clock_service(void) {+    host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &__cclock);+}++/* destructors without a priority execute before destructors with a priority+ *+ * destructors with a higher [numeric] priority value are executed before+ * destructors with a lower priority value.+ *+ * destructor priority values [0,100] are reserved.+ */+__attribute__((destructor(101))) void deallocate_clock_service(void)+{+    mach_port_deallocate(mach_task_self(), __cclock);+}++static void clock_darwin_gettime(struct timespec *t)+{     // OS X does not have clock_gettime, use clock_get_time     // see http://stackoverflow.com/questions/11680461/monotonic-clock-on-osx-    clock_serv_t cclock;     mach_timespec_t mts;--    host_get_clock_service(mach_host_self(), clock, &cclock);-    clock_get_time(cclock, &mts);-    mach_port_deallocate(mach_task_self(), cclock);+    clock_get_time(__cclock, &mts);      t->tv_sec  = mts.tv_sec;     t->tv_nsec = mts.tv_nsec;@@ -44,7 +67,7 @@ double clock_gettime_monotonic_seconds() {     struct timespec t;-    clock_darwin_gettime(SYSTEM_CLOCK, &t);+    clock_darwin_gettime(&t);      return (double) t.tv_sec + (double) t.tv_nsec * 1.0E-9; }

@@ -1,12 +1,343 @@ /*  * Module      : Data.Array.Accelerate.Debug.Flags- * Copyright   : [2017] Trevor L. McDonell+ * Copyright   : [2017..2020] The Accelerate Team  * License     : BSD3  *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>  * Stability   : experimental  * Portability : non-portable (GHC extensions)+ *+ * Option parsing for debug flags. This is a translation of the module+ * Data.Array.Accelerate.Debug.Flags into C, so that we can implement it at+ * program initialisation.+ *+ * This processes flags between +ACC ... -ACC on the command line. The+ * corresponding fields are removed from the command line. Note that we can't at+ * this stage update the number of command line arguments, but with some tricks+ * they can be mostly deleted.  */ -#include "flags.inc"+#include <ctype.h>+#include <getopt.h>+#include <inttypes.h>+#include <libgen.h>+#include <stdint.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>++#include "flags.h"+++/* These globals will be accessed from the Haskell side to implement the+ * corresponding behaviour.+ */++__flags_t __cmd_line_flags            = { 0xff };  // SEE: [layout of command line options bitfield]+uint32_t  __unfolding_use_threshold   = 1;+uint32_t  __max_simplifier_iterations = 25;++enum {+  OPT_ENABLE = 1,+  OPT_DISABLE,+  OPT_UNFOLDING_USE_THRESHOLD,+  OPT_MAX_SIMPLIFIER_ITERATIONS+};++/* NOTE: [layout of command line options bitfield]+ *+ * When adding new options, make sure the offset value in the OPT_DISABLE branch+ * is updated, and that the flags are kept in order.+ */+static const char*         shortopts  = "";+static const struct option longopts[] =+  { { "fseq-sharing",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "facc-sharing",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "fexp-sharing",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "ffusion",                        no_argument,       NULL, OPT_ENABLE                    }+  , { "fsimplify",                      no_argument,       NULL, OPT_ENABLE                    }+  , { "finplace",                       no_argument,       NULL, OPT_ENABLE                    }+  , { "ffast-math",                     no_argument,       NULL, OPT_ENABLE                    }+  , { "ffast-permute-const",            no_argument,       NULL, OPT_ENABLE                    }+  , { "fflush-cache",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "fforce-recomp",                  no_argument,       NULL, OPT_ENABLE                    }++  , { "ddebug",                         no_argument,       NULL, OPT_ENABLE                    }+  , { "dverbose",                       no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-phases",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-sharing",                  no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-fusion",                   no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-simpl-stats",              no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-simpl-iterations",         no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-vectorisation",            no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-dot",                      no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-simpl-dot",                no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-gc",                       no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-gc-stats",                 no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-cc",                       no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-ld",                       no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-asm",                      no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-exec",                     no_argument,       NULL, OPT_ENABLE                    }+  , { "ddump-sched",                    no_argument,       NULL, OPT_ENABLE                    }++  , { "fno-seq-sharing",                no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-acc-sharing",                no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-exp-sharing",                no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-fusion",                     no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-simplify",                   no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-inplace",                    no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-fast-math",                  no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-fast-permute-const",         no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-flush-cache",                no_argument,       NULL, OPT_DISABLE                   }+  , { "fno-force-recomp",               no_argument,       NULL, OPT_DISABLE                   }++  , { "funfolding-use-threshold=INT",   required_argument, NULL, OPT_UNFOLDING_USE_THRESHOLD   }+  , { "fmax-simplifier-iterations=INT", required_argument, NULL, OPT_MAX_SIMPLIFIER_ITERATIONS }++  /* required sentinel */+  , { NULL, 0, NULL, 0 }+  };+++/* Parse the given vector of command line arguments and set the corresponding+ * flags. The vector should contain no non-option arguments (aside from the name+ * of the program as the first entry, which is required for getopt()).+ */+static void parse_options(int argc, char *argv[])+{+  const struct option* opt;+  char* this;+  int   did_show_banner;+  int   prefix;+  int   result;+  int   longindex;++  while (-1 != (result = getopt_long_only(argc, argv, shortopts, longopts, &longindex)))+  {+    switch(result)+    {+    /* the option flag was set */+    case 0:+      break;++    case OPT_ENABLE:+      __cmd_line_flags.bitfield |= 1 << longindex;+      break;++    case OPT_DISABLE:+      __cmd_line_flags.bitfield &= ~(1 << (longindex - 27));  // SEE: [layout of command line options bitfield]+      break;++    /* attempt to decode the argument to flags which require them */+    case OPT_UNFOLDING_USE_THRESHOLD:+      if (1 != sscanf(optarg, "%"PRIu32, &__unfolding_use_threshold)) {+        fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n"+                      , basename(argv[0])+                      , longopts[longindex].name+                      , optarg+                      );+      }+      break;++    case OPT_MAX_SIMPLIFIER_ITERATIONS:+      if (1 != sscanf(optarg, "%"PRIu32, &__max_simplifier_iterations)) {+        fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n"+                      , basename(argv[0])+                      , longopts[longindex].name+                      , optarg+                      );+      }+      break;++    /* option was ambiguous or was missing a required argument+     *+     * TLM: longindex is not being updated correctly on my system for the case+     *      of an ambiguous argument, which makes it tricker to directly test+     *      whether we got here due to a missing argument or ambiguous option.+     */+    case ':':+    case '?':+      opt             = longopts;+      this            = argv[optind-1];+      did_show_banner = 0;++      /* drop the leading '-' from the input command line argument */+      while (*this) {+        if ('-' == *this) {+          ++this;+        } else {+          break;+        }+      }+      prefix = strlen(this);++      /* display any options which are a prefix match for the ambiguous option */+      while (opt->name) {+        if (0 == strncmp(opt->name, this, prefix)) {+          /* only here can we determine if this was a missing argument case */+          if (opt->has_arg == required_argument)+            break;++          /* only show the banner if there are possible matches */+          if (0 == did_show_banner) {+            did_show_banner = 1;+            fprintf(stderr, "Did you mean one of these?\n");+          }+          fprintf(stderr, "    -%s\n", opt->name);+        }+        ++opt;+      }+      break;++    default:+      fprintf(stderr, "failed to process command line options (%d)\n", result);+      abort();+    }+  }++#if !defined(ACCELERATE_DEBUG)+  if (__cmd_line_flags.bitfield & 0x7fffc00) {  // SEE: [layout of command line options bitfield]+    fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n");+    fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n");+  }+#endif+}+++/* This function will be run automatically before main() to process options sent+ * to the Accelerate runtime system.+ *+ * This processes both command line flags as well as those specified via the+ * environment variable "ACCELERATE_FLAGS" (with precedence to the former).+ *+ * The input 'argv' vector is mutated to remove the entries processed by this+ * module. This prevents the flags from interfering with the regular Haskell+ * program (in the same way as the RTS options). Note however that since we can+ * not update the 'argc' length of the vector, the removed entries are simply+ * set to NULL (and moved to the end of the vector).+ */+__attribute__((constructor)) void process_options(int argc, char *argv[])+{+  int i;++  /* Find the command line options which need to be processed. These will be+   * between +ACC ... [-ACC] (similar to the Haskell RTS options).+   *+   * Note that this only recognises a single +ACC ... -ACC group. Should we be+   * able to handle multiple (disjoint) groups of flags? To do this properly we+   * probably want to collect the arguments (from both sources) into a linked+   * list. This would not be particularly difficult, just tedious... \:+   */+  int cl_start;+  int cl_end;+  int num_cl_options = 0;++  for (cl_start = 1; cl_start < argc; ++cl_start) {+    if (0 == strncmp("+ACC", argv[cl_start], 4)) {+      break;+    }+  }++  for (cl_end = cl_start+1; cl_end < argc; ++cl_end) {+    if (0 == strncmp("-ACC", argv[cl_end], 4)) {+      break;+    }+  }+  num_cl_options = cl_end-cl_start-1;++  /* Gather options from the ACCELERATE_FLAGS environment variable. Note that we+   * must not modify this variable, otherwise subsequent invocations of getenv()+   * will get the modified version.+   */+  char *env            = getenv("ACCELERATE_FLAGS");+  int  num_env_options = 0;++  if (NULL != env) {+    /* copy the environment string, as we will mutate it during tokenisation */+    char *p = env = strdup(env);++    /* first count how many tokens there are, so that we can allocate memory for+     * the combined options vector+     */+    while (*p) {+      while (*p && isspace(*p)) ++p;++      if (*p) {+        ++num_env_options;+        while (*p && !isspace(*p)) ++p;+      }+    }+  }++  /* Create the combined options vector containing both the environment and+   * command line options for parsing. The command line options are placed at+   * the end, so that they may override environment options.+   */+  int    argc2 = num_cl_options + num_env_options + 1;+  char** argv2 = NULL;++  if (argc2 > 1) {+    char*  p = env;+    char** r = argv2 = malloc(argc2 * sizeof(char*));++    /* program name */+    *r++ = argv[0];++    /* environment variables */+    if (p) {+      while (*p) {+        while (*p && isspace(*p)) ++p;++        if (*p) {+          *r++ = p;+          while (*p && !isspace(*p)) ++p;++          if (isspace(*p)) {+            *p++ = '\0';+          }+        }+      }+    }++    /* command line flags */+    for (i = cl_start+1; i < cl_end; ++i)+      *r++ = argv[i];++    /* finally process command lines */+    parse_options(argc2, argv2);+  }++  /* Remove the Accelerate options from the command line arguments which will be+   * passed to main(). We can't do this in a sensible fashion by updating argc,+   * but we can pull a small sleight-of-hand by rewriting them to -RTS, so that+   * they will be deleted by the GHC RTS when it is initialised.+   *+   * In this method, we can also updated them in place, without permuting the+   * order of the options to place the (now unused) Accelerate flags at the end+   * of the vector. This does create a slight change in behaviour though, where+   * the application will become more lenient to the user not (correctly)+   * closing the RTS group, for example:+   *+   * > ./foo +RTS -... +ACC -... -ACC+   *+   * is rewritten to:+   *+   * > ./foo +RTS -... -RTS -... -RTS+   *+   * Previously, since the RTS group was not terminated correctly the GHC RTS+   * would complain that the trailing Accelerate options (+ACC -...) were+   * unknown RTS flags.+   */+  for (i = cl_start; i < cl_end+1 && i < argc; ++i) {+    if (strlen(argv[i]) >= 4) {+      strcpy(argv[i], "-RTS");+    } else {+      argv[i][0] = '\0';+    }+  }++  /* cleanup */+  if (argv2) free(argv2);+  if (env)   free(env);+} 

@@ -0,0 +1,52 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Flags+ * Copyright   : [2017..2020] The Accelerate Team+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ */++#ifndef __ACCELERATE_FLAGS_H__+#define __ACCELERATE_FLAGS_H__++/* NOTE: [layout of command line options bitfield]+ */+typedef union {+  uint32_t bitfield;++  struct {+    uint32_t seq_sharing            : 1;+    uint32_t acc_sharing            : 1;+    uint32_t exp_sharing            : 1;+    uint32_t fusion                 : 1;+    uint32_t simplify               : 1;+    uint32_t inplace                : 1;+    uint32_t fast_math              : 1;+    uint32_t fast_permute_const     : 1;+    uint32_t flush_cache            : 1;+    uint32_t force_recomp           : 1;++    uint32_t debug                  : 1;+    uint32_t verbose                : 1;+    uint32_t dump_phases            : 1;+    uint32_t dump_sharing           : 1;+    uint32_t dump_fusion            : 1;+    uint32_t dump_simpl_stats       : 1;+    uint32_t dump_simpl_iterations  : 1;+    uint32_t dump_vectorisation     : 1;+    uint32_t dump_dot               : 1;+    uint32_t dump_simpl_dot         : 1;+    uint32_t dump_gc                : 1;+    uint32_t dump_gc_stats          : 1;+    uint32_t dump_cc                : 1;+    uint32_t dump_ld                : 1;+    uint32_t dump_asm               : 1;+    uint32_t dump_exec              : 1;+    uint32_t dump_sched             : 1;+  };+} __flags_t;++#endif // __ACCELERATE_FLAGS_H__+

@@ -1,336 +0,0 @@-/*- * Module      : Data.Array.Accelerate.Debug.Flags- * Copyright   : [2017] Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- * Portability : non-portable (GHC extensions)- *- * Option parsing for debug flags. This is a translation of the module- * Data.Array.Accelerate.Debug.Flags into C, so that we can implement it at- * program initialisation.- *- * This processes flags between +ACC ... -ACC on the command line. The- * corresponding fields are removed from the command line. Note that we can't at- * this stage update the number of command line arguments, but with some tricks- * they can be mostly deleted.- *- * This is a hack to work around <https://github.com/haskell/cabal/issues/4937>- */--#include <ctype.h>-#include <getopt.h>-#include <libgen.h>-#include <stdint.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>---/* These globals will be accessed from the Haskell side to implement the- * corresponding behaviour.- */-int32_t __acc_sharing               = 1;-int32_t __exp_sharing               = 1;-int32_t __fusion                    = 1;-int32_t __simplify                  = 1;-int32_t __unfolding_use_threshold   = 1;-int32_t __fast_math                 = 1;-int32_t __flush_cache               = 0;-int32_t __force_recomp              = 0;-int32_t __debug                     = 0;--int32_t __verbose                   = 0;-int32_t __dump_phases               = 0;-int32_t __dump_sharing              = 0;-int32_t __dump_fusion               = 0;-int32_t __dump_simpl_stats          = 0;-int32_t __dump_simpl_iterations     = 0;-int32_t __dump_vectorisation        = 0;-int32_t __dump_dot                  = 0;-int32_t __dump_simpl_dot            = 0;-int32_t __dump_gc                   = 0;-int32_t __dump_gc_stats             = 0;-int32_t __dump_cc                   = 0;-int32_t __dump_ld                   = 0;-int32_t __dump_asm                  = 0;-int32_t __dump_exec                 = 0;-int32_t __dump_sched                = 0;--#if defined(ACCELERATE_DEBUG)--static const char*         shortopts  = "";-static const struct option longopts[] =-  { { "dverbose",                     no_argument,       &__verbose,               1    }-  , { "ddump-phases",                 no_argument,       &__dump_phases,           1    }-  , { "ddump-sharing",                no_argument,       &__dump_sharing,          1    }-  , { "ddump-fusion",                 no_argument,       &__dump_fusion,           1    }-  , { "ddump-simpl-stats",            no_argument,       &__dump_simpl_stats,      1    }-  , { "ddump-simpl-iterations",       no_argument,       &__dump_simpl_iterations, 1    }-  , { "ddump-vectorisation",          no_argument,       &__dump_vectorisation,    1    }-  , { "ddump-dot",                    no_argument,       &__dump_dot,              1    }-  , { "ddump-simpl-dot",              no_argument,       &__dump_simpl_dot,        1    }-  , { "ddump-gc",                     no_argument,       &__dump_gc,               1    }-  , { "ddump-gc-stats",               no_argument,       &__dump_gc_stats,         1    }-  , { "ddump-cc",                     no_argument,       &__dump_cc,               1    }-  , { "ddump-ld",                     no_argument,       &__dump_ld,               1    }-  , { "ddump-asm",                    no_argument,       &__dump_asm,              1    }-  , { "ddump-exec",                   no_argument,       &__dump_exec,             1    }-  , { "ddump-sched",                  no_argument,       &__dump_sched,            1    }--  , { "facc-sharing",                 no_argument,       &__acc_sharing,           1    }-  , { "fexp-sharing",                 no_argument,       &__exp_sharing,           1    }-  , { "ffusion",                      no_argument,       &__fusion,                1    }-  , { "fsimplify",                    no_argument,       &__simplify,              1    }-  , { "fflush-cache",                 no_argument,       &__flush_cache,           1    }-  , { "fforce-recomp",                no_argument,       &__force_recomp,          1    }-  , { "ffast-math",                   no_argument,       &__fast_math,             1    }-  , { "fdebug",                       no_argument,       &__debug,                 1    }--  , { "fno-acc-sharing",              no_argument,       &__acc_sharing,           0    }-  , { "fno-exp-sharing",              no_argument,       &__exp_sharing,           0    }-  , { "fno-fusion",                   no_argument,       &__fusion,                0    }-  , { "fno-simplify",                 no_argument,       &__simplify,              0    }-  , { "fno-flush-cache",              no_argument,       &__flush_cache,           0    }-  , { "fno-force-recomp",             no_argument,       &__force_recomp,          0    }-  , { "fno-fast-math",                no_argument,       &__fast_math,             0    }-  , { "fno-debug",                    no_argument,       &__debug,                 0    }--  , { "funfolding-use-threshold=INT", required_argument, NULL,                     1000 }--  /* required sentinel */-  , { NULL, 0, NULL, 0 }-  };--#endif /* ACCELERATE_DEBUG */---/* Parse the given vector of command line arguments and set the corresponding- * flags. The vector should contain no non-option arguments (aside from the name- * of the program as the first entry, which is required for getopt()).- */-static void parse_options(int argc, char *argv[])-{-#if defined(ACCELERATE_DEBUG)--  const struct option* opt;-  char* this;-  int   did_show_banner;-  int   prefix;-  int   result;-  int   longindex;--  while (-1 != (result = getopt_long_only(argc, argv, shortopts, longopts, &longindex)))-  {-    switch(result)-    {-    /* the option flag was set */-    case 0:-      break;--    /* attempt to decode the argument to flags which require them */-    case 1000:-      if (1 != sscanf(optarg, "%d", &__unfolding_use_threshold)) {-        fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n"-                      , basename(argv[0])-                      , longopts[longindex].name-                      , optarg-                      );-      }-      break;--    /* option was ambiguous or was missing a required argument-     *-     * TLM: longindex is not being updated correctly on my system for the case-     *      of an ambiguous argument, which makes it tricker to directly test-     *      whether we got here due to a missing argument or ambiguous option.-     */-    case ':':-    case '?':-      opt             = longopts;-      this            = argv[optind-1];-      did_show_banner = 0;--      /* drop the leading '-' from the input command line argument */-      while (*this) {-        if ('-' == *this) {-          ++this;-        } else {-          break;-        }-      }-      prefix = strlen(this);--      /* display any options which are a prefix match for the ambiguous option */-      while (opt->name) {-        if (0 == strncmp(opt->name, this, prefix)) {-          /* only here can we determine if this was a missing argument case */-          if (opt->has_arg == required_argument)-            break;--          /* only show the banner if there are possible matches */-          if (0 == did_show_banner) {-            did_show_banner = 1;-            fprintf(stderr, "Did you mean one of these?\n");-          }-          fprintf(stderr, "    -%s\n", opt->name);-        }-        ++opt;-      }-      break;--    default:-      fprintf(stderr, "failed to process command line options (%d)\n", result);-      abort();-    }-  }--#else--  fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n");-  fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n");--#endif-}---/* This function will be run automatically before main() to process options sent- * to the Accelerate runtime system.- *- * This processes both command line flags as well as those specified via the- * environment variable "ACCELERATE_FLAGS" (with precedence to the former).- *- * The input 'argv' vector is mutated to remove the entries processed by this- * module. This prevents the flags from interfering with the regular Haskell- * program (in the same way as the RTS options). Note however that since we can- * not update the 'argc' length of the vector, the removed entries are simply- * set to NULL (and moved to the end of the vector).- */-__attribute__((constructor)) void process_options(int argc, char *argv[])-{-  int i;--  /* Find the command line options which need to be processed. These will be-   * between +ACC ... [-ACC] (similar to the Haskell RTS options).-   *-   * Note that this only recognises a single +ACC ... -ACC group. Should we be-   * able to handle multiple (disjoint) groups of flags? To do this properly we-   * probably want to collect the arguments (from both sources) into a linked-   * list. This would not be particularly difficult, just tedious... \:-   */-  int cl_start;-  int cl_end;-  int num_cl_options = 0;--  for (cl_start = 1; cl_start < argc; ++cl_start) {-    if (0 == strncmp("+ACC", argv[cl_start], 4)) {-      break;-    }-  }--  for (cl_end = cl_start+1; cl_end < argc; ++cl_end) {-    if (0 == strncmp("-ACC", argv[cl_end], 4)) {-      break;-    }-  }-  num_cl_options = cl_end-cl_start-1;--  /* Gather options from the ACCELERATE_FLAGS environment variable. Note that we-   * must not modify this variable, otherwise subsequent invocations of getenv()-   * will get the modified version.-   */-  char *env            = getenv("ACCELERATE_FLAGS");-  int  num_env_options = 0;--  if (NULL != env) {-    /* copy the environment string, as we will mutate it during tokenisation */-    char *p = env = strdup(env);--    /* first count how many tokens there are, so that we can allocate memory for-     * the combined options vector-     */-    while (*p) {-      while (*p && isspace(*p)) ++p;--      if (*p) {-        ++num_env_options;-        while (*p && !isspace(*p)) ++p;-      }-    }-  }--  /* Create the combined options vector containing both the environment and-   * command line options for parsing. The command line options are placed at-   * the end, so that they may override environment options.-   */-  int    argc2 = num_cl_options + num_env_options + 1;-  char** argv2 = NULL;--  if (argc2 > 1) {-    char*  p = env;-    char** r = argv2 = malloc(argc2 * sizeof(char*));--    /* program name */-    *r++ = argv[0];--    /* environment variables */-    if (p) {-      while (*p) {-        while (*p && isspace(*p)) ++p;--        if (*p) {-          *r++ = p;-          while (*p && !isspace(*p)) ++p;--          if (isspace(*p)) {-            *p++ = '\0';-          }-        }-      }-    }--    /* command line flags */-    for (i = cl_start+1; i < cl_end; ++i)-      *r++ = argv[i];--    /* finally process command lines */-    parse_options(argc2, argv2);-  }--  /* Remove the Accelerate options from the command line arguments which will be-   * passed to main(). We can't do this in a sensible fashion by updating argc,-   * but we can pull a small sleight-of-hand by rewriting them to -RTS, so that-   * they will be deleted by the GHC RTS when it is initialised.-   *-   * In this method, we can also updated them in place, without permuting the-   * order of the options to place the (now unused) Accelerate flags at the end-   * of the vector. This does create a slight change in behaviour though, where-   * the application will become more lenient to the user not (correctly)-   * closing the RTS group, for example:-   *-   * > ./foo +RTS -... +ACC -... -ACC-   *-   * is rewritten to:-   *-   * > ./foo +RTS -... -RTS -... -RTS-   *-   * Previously, since the RTS group was not terminated correctly the GHC RTS-   * would complain that the trailing Accelerate options (+ACC -...) were-   * unknown RTS flags.-   */-  for (i = cl_start; i < cl_end+1 && i < argc; ++i) {-    if (strlen(argv[i]) >= 4) {-      strcpy(argv[i], "-RTS");-    } else {-      argv[i][0] = '\0';-    }-  }--  /* cleanup */-  if (argv2) free(argv2);-  if (env)   free(env);-}--// vim: filetype=c-

@@ -1,13 +0,0 @@-/*- * Module      : Data.Array.Accelerate.Debug.Flags- * Copyright   : [2017] Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- * Portability : non-portable (GHC extensions)- */--#define ACCELERATE_DEBUG-#include "flags.inc"-

@@ -1,12 +1,142 @@ /*  * Module      : Data.Array.Accelerate.Debug.Monitoring- * Copyright   : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright   : [2016..2020] The Accelerate Team  * License     : BSD3  *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>  * Stability   : experimental  * Portability : non-portable (GHC extensions)+ *+ * Support for runtime system monitoring+ *+ * This is a hack to work around <https://github.com/haskell/cabal/issues/4937>  */ -#include "monitoring.inc"+#include <inttypes.h>+#include <stdint.h>+#include <stdio.h>++#include "flags.h"+++/* These monitoring counters are globals which will be accessed from the+ * Haskell side.+ */+int64_t __active_ns_llvm_native             = 0;+int64_t __active_ns_llvm_ptx                = 0;++int64_t __current_bytes_remote              = 0;+int64_t __current_bytes_nursery             = 0;++int64_t __total_bytes_allocated_local       = 0;+int64_t __total_bytes_allocated_remote      = 0;+int64_t __total_bytes_copied_to_remote      = 0;+int64_t __total_bytes_copied_from_remote    = 0;+int64_t __total_bytes_evicted_from_remote   = 0;+int64_t __num_remote_gcs                    = 0;+int64_t __num_evictions                     = 0;++/* cbits/flags.c */+extern __flags_t __cmd_line_flags;++#if defined(ACCELERATE_DEBUG)++/* cbits/clock.c */+double clock_gettime_elapsed_seconds(void);++/*+ * Format a large number, using comma separators.+ */+static char* format_int64(char *buffer, int64_t x)+{+  char *s = buffer;++  if (x < 0)+  {+    *s++  = '-';+    x     = -x;+  }++  if (x < 1000)+  {+    sprintf(s, "%"PRIi64, x);+  }+  else if (x < 1000000)+  {+    sprintf(s, "%"PRIi64",%03"PRIi64, x/1000, x%1000);+  }+  else if (x < 1000000000)+  {+    sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64+             ,  x/1000000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000)+  {+    sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64+             ,  x/1000000000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000000)+  {+    sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64+             ,  x/1000000000000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000000000)+  {+    sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64+             ,  x/1000000000000000+             , (x/1000000000000)%1000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else+  {+    sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64+             ,  x/1000000000000000000+             , (x/1000000000000000)%1000+             , (x/1000000000000)%1000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }++  return buffer;+}++/*+ * This function runs after main(), and is used to print final GC and memory+ * statistics (if enabled). This is similar to the +RTS -s option.+ */+__attribute__((destructor)) void dump_gc_stats(void)+{+  if (__cmd_line_flags.dump_gc_stats) {+    /*+     * int64 ranges from -9223372036854775807..9223372036854775807, so we need a+     * buffer size of at least 27 characters (including the terminating \0) to+     * format any number with commas.+     */+    char buffer[96];+    double timestamp = clock_gettime_elapsed_seconds();++    fprintf(stderr, "\n");+    fprintf(stderr, "[%8.3f] gc: %s bytes allocated locally\n", timestamp, format_int64(buffer, __total_bytes_allocated_local));+    fprintf(stderr, "[%8.3f] gc: %s bytes allocated on the remote device\n", timestamp, format_int64(buffer, __total_bytes_allocated_remote));+    fprintf(stderr, "[%8.3f] gc: %s bytes copied to the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_to_remote));+    fprintf(stderr, "[%8.3f] gc: %s bytes copied from the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_from_remote));+    fprintf(stderr, "[%8.3f] gc: %s bytes evicted from the remote (%s evictions, %s GCs)\n", timestamp, format_int64(&buffer[0], __total_bytes_evicted_from_remote), format_int64(&buffer[32], __num_evictions), format_int64(&buffer[64], __num_remote_gcs));+  }+}++#endif /* ACCELERATE_DEBUG */ 

@@ -1,141 +0,0 @@-/*- * Module      : Data.Array.Accelerate.Debug.Monitoring- * Copyright   : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- * Portability : non-portable (GHC extensions)- *- * Support for runtime system monitoring- *- * This is a hack to work around <https://github.com/haskell/cabal/issues/4937>- */--#include <stdint.h>-#include <stdio.h>---/* These monitoring counters are globals which will be accessed from the- * Haskell side.- */-int64_t __active_ns_llvm_native             = 0;-int64_t __active_ns_llvm_ptx                = 0;--int64_t __current_bytes_remote              = 0;-int64_t __current_bytes_nursery             = 0;--int64_t __total_bytes_allocated_local       = 0;-int64_t __total_bytes_allocated_remote      = 0;-int64_t __total_bytes_copied_to_remote      = 0;-int64_t __total_bytes_copied_from_remote    = 0;-int64_t __total_bytes_evicted_from_remote   = 0;-int64_t __num_remote_gcs                    = 0;-int64_t __num_evictions                     = 0;--extern int32_t __dump_gc;-extern int32_t __dump_gc_stats;--#if defined(ACCELERATE_DEBUG)--/* cbits/clock.c */-double clock_gettime_elapsed_seconds(void);--/*- * Format a large number, using comma separators.- */-static char* format_int64(char *buffer, int64_t x)-{-  char *s = buffer;--  if (x < 0)-  {-    *s++  = '-';-    x     = -x;-  }--  if (x < 1000)-  {-    sprintf(s, "%lld", x);-  }-  else if (x < 1000000)-  {-    sprintf(s, "%lld,%03lld", x/1000, x%1000);-  }-  else if (x < 1000000000)-  {-    sprintf(s, "%lld,%03lld,%03lld"-             ,  x/1000000-             , (x/1000)%1000-             ,  x%1000);-  }-  else if (x < 1000000000000)-  {-    sprintf(s, "%lld,%03lld,%03lld,%03lld"-             ,  x/1000000000-             , (x/1000000)%1000-             , (x/1000)%1000-             ,  x%1000);-  }-  else if (x < 1000000000000000)-  {-    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld"-             ,  x/1000000000000-             , (x/1000000000)%1000-             , (x/1000000)%1000-             , (x/1000)%1000-             ,  x%1000);-  }-  else if (x < 1000000000000000000)-  {-    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld"-             ,  x/1000000000000000-             , (x/1000000000000)%1000-             , (x/1000000000)%1000-             , (x/1000000)%1000-             , (x/1000)%1000-             ,  x%1000);-  }-  else-  {-    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld,%03lld"-             ,  x/1000000000000000000-             , (x/1000000000000000)%1000-             , (x/1000000000000)%1000-             , (x/1000000000)%1000-             , (x/1000000)%1000-             , (x/1000)%1000-             ,  x%1000);-  }--  return buffer;-}--/*- * This function runs after main(), and is used to print final GC and memory- * statistics (if enabled). This is similar to the +RTS -s option.- */-__attribute__((destructor)) void dump_gc_stats(void)-{-  if (__dump_gc_stats) {-    /*-     * int64 ranges from -9223372036854775807..9223372036854775807, so we need a-     * buffer size of at least 27 characters (including the terminating \0) to-     * format any numbers with commas.-     */-    char buffer[96];-    double timestamp = clock_gettime_elapsed_seconds();--    printf("\n");-    printf("[%8.3f] gc: %s bytes allocated locally\n", timestamp, format_int64(buffer, __total_bytes_allocated_local));-    printf("[%8.3f] gc: %s bytes allocated on the remote device\n", timestamp, format_int64(buffer, __total_bytes_allocated_remote));-    printf("[%8.3f] gc: %s bytes copied to the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_to_remote));-    printf("[%8.3f] gc: %s bytes copied from the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_from_remote));-    printf("[%8.3f] gc: %s bytes evicted from the remote (%s evictions, %s GCs)\n", timestamp, format_int64(&buffer[0], __total_bytes_evicted_from_remote), format_int64(&buffer[32], __num_evictions), format_int64(&buffer[64], __num_remote_gcs));-  }-}--#endif /* ACCELERATE_DEBUG */--// vim: filetype=c-

@@ -1,13 +0,0 @@-/*- * Module      : Data.Array.Accelerate.Debug.Monitoring- * Copyright   : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- * Portability : non-portable (GHC extensions)- */--#define ACCELERATE_DEBUG-#include "monitoring.inc"-

binary file changed (absent → 207024 bytes)

@@ -1,12 +1,13 @@+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2013..2017] Robert Clifton-Everest---               [2014..2014] Frederik M. Madsen+-- Description : The Accelerate standard prelude+-- Copyright   : [2008..2020] The Accelerate Team -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -84,7 +85,7 @@ -- --      - For more information on LULESH: <https://codesign.llnl.gov/lulesh.php>. -----      <<https://codesign.llnl.gov/images/sedov-3d-LLNL.png>>+--      <<https://i.imgur.com/bIkODKd.jpg>> -- -- [/Starting a new project:/] --@@ -109,6 +110,12 @@ -- * <https://hackage.haskell.org/package/accelerate-bignum accelerate-bignum>: -- Fixed-width large integer arithmetic. --+-- * <https://hackage.haskell.org/package/containers-accelerate containers-accelerate>:+-- Container types for use with Accelerate.+--+-- * <https://hackage.haskell.org/package/hashable-accelerate hashable-accelerate>:+-- Class for types which can be converted to a value.+-- -- * <https://hackage.haskell.org/package/colour-accelerate colour-accelerate>: -- Colour representations in Accelerate (RGB, sRGB, HSV, and HSL). --@@ -139,10 +146,7 @@ -- -- * Bug reports: https://github.com/AccelerateHS/accelerate/issues ----- * Maintainers:------     * Trevor L. McDonell: <mailto:tmcdonell@cse.unsw.edu.au>---     * Manuel M T Chakravarty: <mailto:chak@cse.unsw.edu.au>+-- * Maintainer: Trevor L. McDonell: <mailto:trevor.mcdonell@gmail.com> -- -- [/Tip:/] --@@ -200,6 +204,9 @@   -- *** Concatenation   (++), concatOn, +  -- *** Expansion+  expand,+   -- ** Composition   -- *** Flow control   (?|), acond, awhile,@@ -239,7 +246,6 @@   -- *** Permutations   -- **** Forward permutation (scatter)   permute,-  ignore,   scatter,    -- **** Backward permutation (gather)@@ -251,13 +257,14 @@   reverseOn, transposeOn,    -- *** Filtering-  filter,+  filter, compact,    -- ** Folding   fold, fold1, foldAll, fold1All,    -- *** Segmented reductions-  foldSeg, fold1Seg,+  foldSeg,  fold1Seg,+  foldSeg', fold1Seg',    -- *** Specialised reductions   all, any, and, or, sum, product, minimum, maximum,@@ -301,17 +308,20 @@   -- ** Scalar data types   Exp, +  -- ** SIMD vectors+  Vec, VecElt,+   -- ** Type classes   -- *** Basic type classes   Eq(..),-  Ord(..), Ordering(..),+  Ord(..), Ordering(..), pattern LT_, pattern EQ_, pattern GT_,   Enum, succ, pred,   Bounded, minBound, maxBound,    -- *** Numeric type classes   Num, (+), (-), (*), negate, abs, signum, fromInteger,-  -- Real, -- vacuous   Integral, quot, rem, div, mod, quotRem, divMod,+  Rational(..),   Fractional, (/), recip, fromRational,   Floating, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh, exp, sqrt, log, (**), logBase,   RealFrac(..), div', mod', divMod',@@ -328,6 +338,26 @@   lift1, lift2, lift3,   ilift1, ilift2, ilift3, +  -- ** Pattern synonyms+  -- $pattern_synonyms+  --+  pattern Pattern,+  pattern T2,  pattern T3,  pattern T4,  pattern T5,  pattern T6,+  pattern T7,  pattern T8,  pattern T9,  pattern T10, pattern T11,+  pattern T12, pattern T13, pattern T14, pattern T15, pattern T16,++  pattern Z_, pattern Ix, pattern (::.),+  pattern I0, pattern I1, pattern I2, pattern I3, pattern I4,+  pattern I5, pattern I6, pattern I7, pattern I8, pattern I9,++  pattern Vec2, pattern V2,+  pattern Vec3, pattern V3,+  pattern Vec4, pattern V4,+  pattern Vec8, pattern V8,+  pattern Vec16, pattern V16,++  mkPattern, mkPatterns,+   -- ** Scalar operations   -- *** Introduction   constant,@@ -336,7 +366,7 @@   fst, afst, snd, asnd, curry, uncurry,    -- *** Flow control-  (?), caseof, cond, while, iterate,+  (?), match, cond, while, iterate,    -- *** Scalar reduction   sfoldl,@@ -378,36 +408,49 @@   fromList, toList,    -- ----------------------------------------------------------------------------  -- * Prelude re-exports-  (.), ($), error, undefined, const,+  -- * Useful re-exports+  (.), ($), (&), error, undefined, const, otherwise,+  Show, Generic, HasCallStack,    -- ---------------------------------------------------------------------------   -- Types   Int, Int8, Int16, Int32, Int64,   Word, Word8, Word16, Word32, Word64,   Half(..), Float, Double,-  Bool(..), Char,+  Bool(..), pattern True_, pattern False_,+  Maybe(..), pattern Nothing_, pattern Just_,+  Char,    CFloat, CDouble,   CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong,   CChar, CSChar, CUChar, -  -- | Avoid using these in your own functions wherever possible.-  IsScalar, IsNum, IsBounded, IsIntegral, IsFloating, IsNonNum,- ) where --- friends-import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), (!!), rank, shape, reshape, size, toIndex, fromIndex, intersect, ignore ) import Data.Array.Accelerate.Classes+import Data.Array.Accelerate.Data.Maybe import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Pattern+import Data.Array.Accelerate.Pattern.TH import Data.Array.Accelerate.Prelude-import Data.Array.Accelerate.Trafo                                  () -- show instances+import Data.Array.Accelerate.Pretty                                 () -- show instances+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Sugar.Array                            ( Array, Arrays, Scalar, Vector, Matrix, Segments, fromFunction, fromFunctionM, toList, fromList )+import Data.Array.Accelerate.Sugar.Elt+import Data.Array.Accelerate.Sugar.Shape                            hiding ( size, toIndex, fromIndex, intersect )+import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.Array.Sugar                  as S+import Data.Primitive.Vec+import qualified Data.Array.Accelerate.Sugar.Array                  as S+import qualified Data.Array.Accelerate.Sugar.Shape                  as S -import Prelude                                                      ( (.), ($), undefined, error, const )+import Data.Function                                                ( (&) )+import Prelude                                                      ( (.), ($), Char, Show, undefined, error, const, otherwise ) +import GHC.Generics                                                 ( Generic )+import GHC.Stack++ -- $setup -- >>> :seti -XTypeOperators -- >>> import Data.Array.Accelerate.Interpreter@@ -425,34 +468,40 @@  -- | Array indexing in plain Haskell code. ---indexArray :: Array sh e -> sh -> e+{-# INLINE indexArray #-}+indexArray :: (Shape sh, Elt e) => Array sh e -> sh -> e indexArray = (S.!)  -- | Linear array indexing in plain Haskell code. ---linearIndexArray :: Array sh e -> Int -> e+{-# INLINE linearIndexArray #-}+linearIndexArray :: Elt e => Array sh e -> Int -> e linearIndexArray = (S.!!) --- | Rank of an array.+-- | Rank of an array (as a plain Haskell value) ---arrayRank :: Shape sh => sh -> Int-arrayRank = S.rank+{-# INLINE arrayRank #-}+arrayRank :: forall sh e. Shape sh => Array sh e -> Int+arrayRank _ = S.rank @sh --- |Array shape in plain Haskell code.+-- | Shape of an array (as a plain Haskell value) --+{-# INLINE arrayShape #-} arrayShape :: Shape sh => Array sh e -> sh arrayShape = S.shape -- rename as 'shape' is already used by the EDSL to query an array's shape --- | Total number of elements in an array of the given 'Shape'.+-- | Total number of elements in an array (as a plain Haskell value) ---arraySize :: Shape sh => sh -> Int-arraySize = S.size+{-# INLINE arraySize #-}+arraySize :: Shape sh => Array sh e -> Int+arraySize = S.size . S.shape  -- | Change the shape of an array without altering its contents. The 'arraySize' -- of the source and result arrays must be identical. ---arrayReshape :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> Array sh e+{-# INLINE arrayReshape #-}+arrayReshape :: (Shape sh, Shape sh') => sh -> Array sh' e -> Array sh e arrayReshape = S.reshape  @@ -549,6 +598,61 @@ -- > fst :: forall a b. (Elt a, Elt b) => Exp (a,b) -> Exp a -- > fst t = let (x,y) = unlift t  :: (Exp a, Exp b) -- >         in x+--+-- For an alternative, see section <#pattern_synonyms Pattern synonyms>.+--++-- $pattern_synonyms+-- #pattern_synonyms#+--+-- Pattern synonyms can be used as an alternative to 'lift' and 'unlift' for+-- constructing and accessing data types isomorphic to simple product (tuple)+-- types.+--+-- In contrast to 'lift' and 'unlift' however, pattern synonyms do /not/ require+-- these data types to be fully polymorphic.+--+-- For example, let's say we have regular Haskell data type representing a point+-- in two-dimensional space:+--+-- > data Point = Point_ Float Float+-- >   deriving (Generic, Elt)+--+-- Here we derive instance an instance of the 'Elt' class (via 'Generic'),+-- so that this data type can be used within scalar Accelerate expressions+--+-- In order to access the individual fields of the data constructor from within+-- an Accelerate expression, we define the following pattern synonym:+--+-- > pattern Point :: Exp Float -> Exp Float -> Exp Point+-- > pattern Point x y = Pattern (x,y)+--+-- Notice how we named the constructor of our original datatype with a trailing+-- underscore, so that we can use the undecorated name for the pattern synonym;+-- these must have unique names.+--+-- In essence, the 'Pattern' pattern is really telling GHC how to treat our @Point@+-- type as a regular pair for use in Accelerate code. The pattern can then be+-- used on both the left and right hand side of an expression:+--+-- > addPoint :: Exp Point -> Exp Point -> Exp Point+-- > addPoint (Point x1 y1) (Point x2 y2) = Point (x1+x2) (y1+y2)+--+-- Similarly, we can define pattern synonyms for values in 'Acc'. We can also+-- use record syntax to generate field accessors, if we desire:+--+-- > data SparseVector a = SparseVector_ (Vector Int) (Vector a)+-- >   deriving (Generic, Arrays)+-- >+-- > pattern SparseVector :: Elt a => Acc (Vector Int) -> Acc (Vector a) -> Acc (SparseVector a)+-- > pattern SparseVector { indices, values } = Pattern (indices, values)+--+-- For convenience, we have defined several pattern synonyms for regular tuples,+-- 'T2' (for pairs), 'T3' (for triples), and so on up to 'T16'. These are+-- occasionally more convenient to use than 'lift' and 'unlift' together with+-- the regular tuple syntax.+--+-- @since 1.3.0.0 --  -- $getting_data_in

@@ -1,1931 +1,1420 @@ {-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE QuasiQuotes           #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.AST--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2010..2011] Ben Lever---               [2013..2017] Robert Clifton-Everest---               [2014..2014] Frederik M. Madsen--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ /Scalar versus collective operations/------ The embedded array processing language is a two-level language.  It--- combines a language of scalar expressions and functions with a language of--- collective array operations.  Scalar expressions are used to compute--- arguments for collective operations and scalar functions are used to--- parametrise higher-order, collective array operations.  The two-level--- structure, in particular, ensures that collective operations cannot be--- parametrised with collective operations; hence, we are following a flat--- data-parallel model.  The collective operations manipulate--- multi-dimensional arrays whose shape is explicitly tracked in their types.--- In fact, collective operations cannot produce any values other than--- multi-dimensional arrays; when they yield a scalar, this is in the form of--- a 0-dimensional, singleton array.  Similarly, scalar expression can -as--- their name indicates- only produce tuples of scalar, but not arrays.------ There are, however, two expression forms that take arrays as arguments.  As--- a result scalar and array expressions are recursively dependent.  As we--- cannot and don't want to compute arrays in the middle of scalar--- computations, array computations will always be hoisted out of scalar--- expressions.  So that this is always possible, these array expressions may--- not contain any free scalar variables.  To express that condition in the--- type structure, we use separate environments for scalar and array variables.------ /Programs/------ Collective array programs comprise closed expressions of array operations.--- There is no explicit sharing in the initial AST form, but sharing is--- introduced subsequently by common subexpression elimination and floating--- of array computations.------ /Functions/------ The array expression language is first-order and only provides limited--- control structures to ensure that it can be efficiently executed on--- compute-acceleration hardware, such as GPUs.  To restrict functions to--- first-order, we separate function abstraction from the main expression--- type.  Functions are represented using de Bruijn indices.------ /Parametric and ad-hoc polymorphism/------ The array language features paramatric polymophism (e.g., pairing and--- projections) as well as ad-hoc polymorphism (e.g., arithmetic operations).--- All ad-hoc polymorphic constructs include reified dictionaries (c.f.,--- module 'Types').  Reified dictionaries also ensure that constants--- (constructor 'Const') are representable on compute acceleration hardware.------ The AST contains both reified dictionaries and type class constraints.--- Type classes are used for array-related functionality that is uniformly--- available for all supported types.  In contrast, reified dictionaries are--- used for functionality that is only available for certain types, such as--- arithmetic operations.-----module Data.Array.Accelerate.AST (--  -- * Typed de Bruijn indices-  Idx(..), idxToInt, tupleIdxToInt,--  -- * Valuation environment-  Val(..), ValElt(..), prj, prjElt,--  -- * Accelerated array expressions-  PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,-  PreBoundary(..), Boundary, Stencil(..), StencilR(..),--  -- * Accelerated sequences-  -- PreOpenSeq(..), Seq,-  -- Producer(..), Consumer(..),--  -- * Scalar expressions-  PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..),-  PrimFun(..),--  -- NFData-  NFDataAcc,-  rnfPreOpenAfun, rnfPreOpenAcc, rnfPreOpenFun, rnfPreOpenExp,-  rnfArrays,--  -- TemplateHaskell-  LiftAcc,-  liftIdx, liftTupleIdx, liftArrays,-  liftConst, liftSliceIndex, liftPrimConst, liftPrimFun,-  liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp,--  -- debugging-  showPreAccOp, showPreExpOp,--) where----standard library-import Control.DeepSeq-import Data.List-import Data.Typeable-import Foreign.ForeignPtr-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import System.IO.Unsafe-import GHC.Ptr                                                      ( Ptr(..) )-import Language.Haskell.TH                                          ( Q, TExp )-import qualified Language.Haskell.TH                                as TH-import qualified Language.Haskell.TH.Syntax                         as TH-#if __GLASGOW_HASKELL__ <= 708-import Instances.TH.Lift                                            () -- Int8, Int16...-#endif---- friends-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..), size )-import Data.Array.Accelerate.Array.Sugar                            hiding ( size )-import Data.Array.Accelerate.Array.Unique-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type-#if __GLASGOW_HASKELL__ < 800-import Data.Array.Accelerate.Error-#endif----- Typed de Bruijn indices--- --------------------------- De Bruijn variable index projecting a specific type from a type--- environment.  Type environments are nested pairs (..((), t1), t2, ..., tn).----data Idx env t where-  ZeroIdx ::              Idx (env, t) t-  SuccIdx :: Idx env t -> Idx (env, s) t---- de Bruijn Index to Int conversion----idxToInt :: Idx env t -> Int-idxToInt ZeroIdx       = 0-idxToInt (SuccIdx idx) = 1 + idxToInt idx--tupleIdxToInt :: TupleIdx tup e -> Int-tupleIdxToInt ZeroTupIdx       = 0-tupleIdxToInt (SuccTupIdx idx) = 1 + tupleIdxToInt idx----- Environments--- ---------------- Valuation for an environment----data Val env where-  Empty :: Val ()-  Push  :: Val env -> t -> Val (env, t)--deriving instance Typeable Val---- Valuation for an environment of array elements----data ValElt env where-  EmptyElt :: ValElt ()-  PushElt  :: Elt t-           => ValElt env -> EltRepr t -> ValElt (env, t)---- Projection of a value from a valuation using a de Bruijn index----prj :: Idx env t -> Val env -> t-prj ZeroIdx       (Push _   v) = v-prj (SuccIdx idx) (Push val _) = prj idx val-#if __GLASGOW_HASKELL__ < 800-prj _             _            = $internalError "prj" "inconsistent valuation"-#endif---- Projection of a value from a valuation of array elements using a de Bruijn index----prjElt :: Idx env t -> ValElt env -> t-prjElt ZeroIdx       (PushElt _   v) = toElt v-prjElt (SuccIdx idx) (PushElt val _) = prjElt idx val-#if __GLASGOW_HASKELL__ < 800-prjElt _             _               = $internalError "prjElt" "inconsistent valuation"-#endif---- Array expressions--- --------------------- |Function abstraction over parametrised array computations----data PreOpenAfun acc aenv t where-  Abody :: Arrays t => acc             aenv      t -> PreOpenAfun acc aenv t-  Alam  :: Arrays a => PreOpenAfun acc (aenv, a) t -> PreOpenAfun acc aenv (a -> t)---- Function abstraction over vanilla open array computations----type OpenAfun = PreOpenAfun OpenAcc---- |Parametrised array-computation function without free array variables----type PreAfun acc = PreOpenAfun acc ()---- |Vanilla array-computation function without free array variables----type Afun = OpenAfun ()---- Vanilla open array computations----newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t)---- |Closed array expression aka an array program----type Acc = OpenAcc ()--deriving instance Typeable PreOpenAcc-deriving instance Typeable OpenAcc----- |Collective array computations parametrised over array variables--- represented with de Bruijn indices.------ * Scalar functions and expressions embedded in well-formed array---   computations cannot contain free scalar variable indices.  The latter---   cannot be bound in array computations, and hence, cannot appear in any---   well-formed program.------ * The let-form is used to represent the sharing discovered by common---   subexpression elimination as well as to control evaluation order.  (We---   need to hoist array expressions out of scalar expressions - they occur in---   scalar indexing and in determining an arrays shape.)------ The data type is parameterised over the surface types (not the representation--- type).------ We use a non-recursive variant parametrised over the recursive closure, to facilitate attribute--- calculation in the backend.----data PreOpenAcc acc aenv a where--  -- Local binding to represent sharing and demand explicitly; this is an-  -- eager(!) binding-  Alet        :: (Arrays bndArrs, Arrays bodyArrs)-              => acc            aenv            bndArrs         -- bound expression-              -> acc            (aenv, bndArrs) bodyArrs        -- the bound expression scope-              -> PreOpenAcc acc aenv            bodyArrs--  -- Variable bound by a 'Let', represented by a de Bruijn index-  Avar        :: Arrays arrs-              => Idx            aenv arrs-              -> PreOpenAcc acc aenv arrs--  -- Tuples of arrays-  Atuple      :: (Arrays arrs, IsAtuple arrs)-              => Atuple    (acc aenv) (TupleRepr arrs)-              -> PreOpenAcc acc aenv  arrs--  Aprj        :: (Arrays arrs, IsAtuple arrs, Arrays a)-              => TupleIdx (TupleRepr arrs) a-              ->            acc aenv arrs-              -> PreOpenAcc acc aenv a--  -- Array-function application.-  ---  -- The array function is not closed at the core level because we need access-  -- to free variables introduced by 'run1' style evaluators. See Issue#95.-  ---  Apply       :: (Arrays arrs1, Arrays arrs2)-              => PreOpenAfun acc aenv (arrs1 -> arrs2)-              -> acc             aenv arrs1-              -> PreOpenAcc  acc aenv arrs2--  -- Apply a backend-specific foreign function to an array, with a pure-  -- Accelerate version for use with other backends. The functions must be-  -- closed.-  Aforeign    :: (Arrays as, Arrays bs, Foreign asm)-              => asm                   (as -> bs)               -- The foreign function for a given backend-              -> PreAfun      acc      (as -> bs)               -- Fallback implementation(s)-              -> acc              aenv as                       -- Arguments to the function-              -> PreOpenAcc   acc aenv bs--  -- If-then-else for array-level computations-  Acond       :: Arrays arrs-              => PreExp     acc aenv Bool-              -> acc            aenv arrs-              -> acc            aenv arrs-              -> PreOpenAcc acc aenv arrs--  -- Value-recursion for array-level computations-  Awhile      :: Arrays arrs-              => PreOpenAfun acc aenv (arrs -> Scalar Bool)     -- continue iteration while true-              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate-              -> acc             aenv arrs                      -- initial value-              -> PreOpenAcc  acc aenv arrs---  -- Array inlet (triggers async host->device transfer if necessary)-  Use         :: Arrays arrs-              => ArrRepr arrs-              -> PreOpenAcc acc aenv arrs--  -- Capture a scalar (or a tuple of scalars) in a singleton array-  Unit        :: Elt e-              => PreExp     acc aenv e-              -> PreOpenAcc acc aenv (Scalar e)--  -- Change the shape of an array without altering its contents-  -- > precondition: size dim == size dim'-  Reshape     :: (Shape sh, Shape sh', Elt e)-              => PreExp     acc aenv sh                         -- new shape-              -> acc            aenv (Array sh' e)              -- array to be reshaped-              -> PreOpenAcc acc aenv (Array sh e)--  -- Construct a new array by applying a function to each index.-  Generate    :: (Shape sh, Elt e)-              => PreExp     acc aenv sh                         -- output shape-              -> PreFun     acc aenv (sh -> e)                  -- representation function-              -> PreOpenAcc acc aenv (Array sh e)--  -- Hybrid map/backpermute, where we separate the index and value-  -- transformations.-  Transform   :: (Elt a, Elt b, Shape sh, Shape sh')-              => PreExp     acc aenv sh'                        -- dimension of the result-              -> PreFun     acc aenv (sh' -> sh)                -- index permutation function-              -> PreFun     acc aenv (a   -> b)                 -- function to apply at each element-              ->            acc aenv (Array sh  a)              -- source array-              -> PreOpenAcc acc aenv (Array sh' b)--  -- Replicate an array across one or more dimensions as given by the first-  -- argument-  Replicate   :: (Shape sh, Shape sl, Elt slix, Elt e)-              => SliceIndex (EltRepr slix)                      -- slice type specification-                            (EltRepr sl)-                            co-                            (EltRepr sh)-              -> PreExp     acc aenv slix                       -- slice value specification-              -> acc            aenv (Array sl e)               -- data to be replicated-              -> PreOpenAcc acc aenv (Array sh e)--  -- Index a sub-array out of an array; i.e., the dimensions not indexed are-  -- returned whole-  Slice       :: (Shape sh, Shape sl, Elt slix, Elt e)-              => SliceIndex (EltRepr slix)                      -- slice type specification-                            (EltRepr sl)-                            co-                            (EltRepr sh)-              -> acc            aenv (Array sh e)               -- array to be indexed-              -> PreExp     acc aenv slix                       -- slice value specification-              -> PreOpenAcc acc aenv (Array sl e)--  -- Apply the given unary function to all elements of the given array-  Map         :: (Shape sh, Elt e, Elt e')-              => PreFun     acc aenv (e -> e')-              -> acc            aenv (Array sh e)-              -> PreOpenAcc acc aenv (Array sh e')--  -- Apply a given binary function pairwise to all elements of the given arrays.-  -- The length of the result is the length of the shorter of the two argument-  -- arrays.-  ZipWith     :: (Shape sh, Elt e1, Elt e2, Elt e3)-              => PreFun     acc aenv (e1 -> e2 -> e3)-              -> acc            aenv (Array sh e1)-              -> acc            aenv (Array sh e2)-              -> PreOpenAcc acc aenv (Array sh e3)--  -- Fold along the innermost dimension of an array with a given /associative/ function.-  Fold        :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- default value-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> PreOpenAcc acc aenv (Array sh e)--  -- 'Fold' without a default value-  Fold1       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> PreOpenAcc acc aenv (Array sh e)--  -- Segmented fold along the innermost dimension of an array with a given /associative/ function-  FoldSeg     :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- default value-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> acc            aenv (Segments i)               -- segment descriptor-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- 'FoldSeg' without a default value-  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> acc            aenv (Segments i)               -- segment descriptor-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Left-to-right Haskell-style scan of a linear array with a given *associative*-  -- function and an initial element (which does not need to be the neutral of the-  -- associative operations)-  Scanl       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Like 'Scan', but produces a rightmost fold value and an array with the same length as the input-  -- array (the fold value would be the rightmost element in a Haskell-style scan)-  Scanl'      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)--  -- Haskell-style scan without an initial value-  Scanl1      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Right-to-left version of 'Scanl'-  Scanr       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Right-to-left version of 'Scanl\''-  Scanr'      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)--  -- Right-to-left version of 'Scanl1'-  Scanr1      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Generalised forward permutation is characterised by a permutation function-  -- that determines for each element of the source array where it should go in-  -- the output. The permutation can be between arrays of varying shape and-  -- dimensionality.-  ---  -- Other characteristics of the permutation function 'f':-  ---  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'-  --      (i.e. a tuple of -1 values) then those elements of the domain are-  --      dropped.-  ---  --   2. 'f' is not surjective: positions in the target array need not be-  --      picked up by the permutation function, so the target array must first-  --      be initialised from an array of default values.-  ---  --   3. 'f' is not injective: distinct elements of the domain may map to the-  --      same position in the target array. In this case the combination-  --      function is used to combine elements, which needs to be /associative/-  --      and /commutative/.-  ---  Permute     :: (Shape sh, Shape sh', Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array sh' e)              -- default values-              -> PreFun     acc aenv (sh -> sh')                -- permutation function-              -> acc            aenv (Array sh e)               -- source array-              -> PreOpenAcc acc aenv (Array sh' e)--  -- Generalised multi-dimensional backwards permutation; the permutation can-  -- be between arrays of varying shape; the permutation function must be total-  Backpermute :: (Shape sh, Shape sh', Elt e)-              => PreExp     acc aenv sh'                        -- dimensions of the result-              -> PreFun     acc aenv (sh' -> sh)                -- permutation function-              -> acc            aenv (Array sh e)               -- source array-              -> PreOpenAcc acc aenv (Array sh' e)--  -- Map a stencil over an array.  In contrast to 'map', the domain of a stencil function is an-  -- entire /neighbourhood/ of each array element.-  Stencil     :: (Elt e, Elt e', Stencil sh e stencil)-              => PreFun      acc aenv (stencil -> e')           -- stencil function-              -> PreBoundary acc aenv (Array sh e)              -- boundary condition-              -> acc             aenv (Array sh e)              -- source array-              -> PreOpenAcc  acc aenv (Array sh e')--  -- Map a binary stencil over an array.-  Stencil2    :: (Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2)-              => PreFun      acc aenv (stencil1 -> stencil2 -> c) -- stencil function-              -> PreBoundary acc aenv (Array sh a)                -- boundary condition #1-              -> acc             aenv (Array sh a)                -- source array #1-              -> PreBoundary acc aenv (Array sh b)                -- boundary condition #2-              -> acc             aenv (Array sh b)                -- source array #2-              -> PreOpenAcc acc  aenv (Array sh c)--  -- A sequence of operations.-  -- Collect     :: Arrays arrs-  --             => PreOpenSeq acc aenv () arrs-  --             -> PreOpenAcc acc aenv arrs--{---data PreOpenSeq acc aenv senv arrs where-  Producer :: Arrays a-           => Producer acc aenv senv a-           -> PreOpenSeq acc aenv (senv, a) arrs-           -> PreOpenSeq acc aenv senv arrs--  Consumer :: Arrays arrs-           => Consumer acc aenv senv arrs-           -> PreOpenSeq acc aenv senv arrs--  Reify    :: Arrays arrs-           => Idx senv arrs-           -> PreOpenSeq acc aenv senv [arrs]--data Producer acc aenv senv a where-  -- Convert the given Haskell-list of arrays to a sequence.-  StreamIn :: Arrays a-           => [a]-           -> Producer acc aenv senv a--  -- Convert the given array to a sequence.-  ToSeq :: (Elt slix, Shape sl, Shape sh, Elt e)-           => SliceIndex  (EltRepr slix)-                          (EltRepr sl)-                          co-                          (EltRepr sh)-           -> proxy slix-           -> acc aenv (Array sh e)-           -> Producer acc aenv senv (Array sl e)--  -- Apply the given the given function to all elements of the given-  -- sequence.-  MapSeq :: (Arrays a, Arrays b)-         => PreOpenAfun acc aenv (a -> b)-         -> Idx senv a-         -> Producer acc aenv senv b--  -- Apply the given the given function to all elements of the given-  -- sequence.-  ChunkedMapSeq :: (Arrays a, Arrays b)-                => PreOpenAfun acc aenv (Vector' a -> Vector' b)-                -> Idx senv a-                -> Producer acc aenv senv b--  -- Apply a given binary function pairwise to all elements of the-  -- given sequences.-  ZipWithSeq :: (Arrays a, Arrays b, Arrays c)-             => PreOpenAfun acc aenv (a -> b -> c)-             -> Idx senv a-             -> Idx senv b-             -> Producer acc aenv senv c--  -- ScanSeq (+) a0 x. Scan a sequence x by combining each element-  -- using the given binary operation (+). (+) must be associative:-  ---  --   Forall a b c. (a + b) + c = a + (b + c),-  ---  -- and a0 must be the identity element for (+):-  ---  --   Forall a. a0 + a = a = a + a0.-  ---  ScanSeq :: Elt e-          => PreFun acc aenv (e -> e -> e)-          -> PreExp acc aenv e-          -> Idx senv (Scalar e)-          -> Producer acc aenv senv (Scalar e)--data Consumer acc aenv senv a where--  -- FoldSeq (+) a0 x. Fold a sequence x by combining each element-  -- using the given binary operation (+). (+) must be associative:-  ---  --   Forall a b c. (a + b) + c = a + (b + c),-  ---  -- and a0 must be the identity element for (+):-  ---  --   Forall a. a0 + a = a = a + a0.-  ---  FoldSeq :: Elt a-          => PreFun acc aenv (a -> a -> a)-          -> PreExp acc aenv a-          -> Idx senv (Scalar a)-          -> Consumer acc aenv senv (Scalar a)--  -- FoldSeqFlatten f a0 x. A specialized version of FoldSeqAct where-  -- reduction with the companion operator corresponds to-  -- flattening. f must be semi-associative, with vecotor append (++)-  -- as the companion operator:-  ---  --   Forall b sh1 a1 sh2 a2.-  --     f (f b sh1 a1) sh2 a2 = f b (sh1 ++ sh2) (a1 ++ a2).-  ---  -- It is common to ignore the shape vectors, yielding the usual-  -- semi-associativity law:-  ---  --   f b a _ = b + a,-  ---  -- for some (+) satisfying:-  ---  --   Forall b a1 a2. (b + a1) + a2 = b + (a1 ++ a2).-  ---  FoldSeqFlatten :: (Arrays a, Shape sh, Elt e)-                 => PreOpenAfun acc aenv (a -> Vector sh -> Vector e -> a)-                 -> acc aenv a-                 -> Idx senv (Array sh e)-                 -> Consumer acc aenv senv a--  Stuple :: (Arrays a, IsAtuple a)-         => Atuple (Consumer acc aenv senv) (TupleRepr a)-         -> Consumer acc aenv senv a---- |Closed sequence computation----type Seq = PreOpenSeq OpenAcc () ()---}----- | Vanilla stencil boundary condition----type Boundary = PreBoundary OpenAcc---- | Boundary condition specification for stencil operations----data PreBoundary (acc :: * -> * -> *) aenv t where-  -- Clamp coordinates to the extent of the array-  Clamp     :: PreBoundary acc aenv t--  -- Mirror coordinates beyond the array extent-  Mirror    :: PreBoundary acc aenv t--  -- Wrap coordinates around on each dimension-  Wrap      :: PreBoundary acc aenv t--  -- Use a constant value for outlying coordinates-  Constant  :: Elt e-            => EltRepr e-            -> PreBoundary acc aenv (Array sh e)--  -- Apply the given function to outlying coordinates-  Function  :: (Shape sh, Elt e)-            => PreFun acc aenv (sh -> e)-            -> PreBoundary acc aenv (Array sh e)----- | Operations on stencils----class (Shape sh, Elt e, IsTuple stencil, Elt stencil) => Stencil sh e stencil where-  stencil :: StencilR sh e stencil---- | GADT reifying the 'Stencil' class----data StencilR sh e pat where-  StencilRunit3 :: Elt e => StencilR DIM1 e (e,e,e)-  StencilRunit5 :: Elt e => StencilR DIM1 e (e,e,e,e,e)-  StencilRunit7 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e)-  StencilRunit9 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e,e,e)--  StencilRtup3  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR (sh:.Int) e (pat1,pat2,pat3)--  StencilRtup5  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5)--  StencilRtup7  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR sh e pat6-                -> StencilR sh e pat7-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7)--  StencilRtup9  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR sh e pat6-                -> StencilR sh e pat7-                -> StencilR sh e pat8-                -> StencilR sh e pat9-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7,pat8,pat9)----- Note: [Stencil reification class]------ We cannot start with 'DIM0'.  The 'IsTuple stencil' superclass would at--- 'DIM0' imply that the types of individual array elements are in 'IsTuple'.--- (That would only possible if we could have (degenerate) 1-tuple, but we can't--- as we can't distinguish between a 1-tuple of a pair and a simple pair.)--- Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the recursive--- case (to avoid overlapping instances).---- DIM1-instance Elt e => Stencil DIM1 e (e, e, e) where-  stencil = StencilRunit3--instance Elt e => Stencil DIM1 e (e, e, e, e, e) where-  stencil = StencilRunit5--instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e) where-  stencil = StencilRunit7--instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e, e, e) where-  stencil = StencilRunit9---- DIM(n+1), where n>1-instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3) => Stencil (sh:.Int:.Int) a (row1, row2, row3) where-  stencil = StencilRtup3 stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where-  stencil = StencilRtup5 stencil stencil stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where-  stencil = StencilRtup7 stencil stencil stencil stencil stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7,-          Stencil (sh:.Int) a row8,-          Stencil (sh:.Int) a row9)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where-  stencil = StencilRtup9 stencil stencil stencil stencil stencil stencil stencil stencil stencil----- Embedded expressions--- ------------------------ |Parametrised open function abstraction----data PreOpenFun (acc :: * -> * -> *) env aenv t where-  Body :: Elt t => PreOpenExp acc env      aenv t -> PreOpenFun acc env aenv t-  Lam  :: Elt a => PreOpenFun acc (env, a) aenv t -> PreOpenFun acc env aenv (a -> t)---- |Vanilla open function abstraction----type OpenFun = PreOpenFun OpenAcc---- |Parametrised function without free scalar variables----type PreFun acc = PreOpenFun acc ()---- |Vanilla function without free scalar variables----type Fun = OpenFun ()---- |Vanilla open expression----type OpenExp = PreOpenExp OpenAcc---- |Parametrised expression without free scalar variables----type PreExp acc = PreOpenExp acc ()---- |Vanilla expression without free scalar variables----type Exp = OpenExp ()---- |Parametrised open expressions using de Bruijn indices for variables ranging over tuples--- of scalars and arrays of tuples.  All code, except Cond, is evaluated eagerly.  N-tuples are--- represented as nested pairs.------ The data type is parametrised over the surface types (not the representation type).----data PreOpenExp (acc :: * -> * -> *) env aenv t where--  -- Local binding of a scalar expression-  Let           :: (Elt bnd_t, Elt body_t)-                => PreOpenExp acc env          aenv bnd_t-                -> PreOpenExp acc (env, bnd_t) aenv body_t-                -> PreOpenExp acc env          aenv body_t--  -- Variable index, ranging only over tuples or scalars-  Var           :: Elt t-                => Idx env t-                -> PreOpenExp acc env aenv t--  -- Apply a backend-specific foreign function-  Foreign       :: (Foreign asm, Elt x, Elt y)-                => asm           (x -> y)           -- foreign function-                -> PreFun acc () (x -> y)           -- alternate implementation (for other backends)-                -> PreOpenExp acc env aenv x-                -> PreOpenExp acc env aenv y--  -- Tuples-  Tuple         :: (Elt t, IsTuple t)-                => Tuple (PreOpenExp acc env aenv) (TupleRepr t)-                -> PreOpenExp acc env aenv t--  Prj           :: (Elt t, IsTuple t, Elt e)-                => TupleIdx (TupleRepr t) e-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv e--  -- Array indices & shapes-  IndexNil      :: PreOpenExp acc env aenv Z--  IndexCons     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv sl-                -> PreOpenExp acc env aenv a-                -> PreOpenExp acc env aenv (sl:.a)--  IndexHead     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv (sl:.a)-                -> PreOpenExp acc env aenv a--  IndexTail     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv (sl:.a)-                -> PreOpenExp acc env aenv sl--  IndexAny      :: Shape sh-                => PreOpenExp acc env aenv (Any sh)--  IndexSlice    :: (Shape sh, Shape sl, Elt slix)-                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-                -> PreOpenExp acc env aenv slix-                -> PreOpenExp acc env aenv sh-                -> PreOpenExp acc env aenv sl--  IndexFull     :: (Shape sh, Shape sl, Elt slix)-                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-                -> PreOpenExp acc env aenv slix-                -> PreOpenExp acc env aenv sl-                -> PreOpenExp acc env aenv sh--  -- Shape and index conversion-  ToIndex       :: Shape sh-                => PreOpenExp acc env aenv sh           -- shape of the array-                -> PreOpenExp acc env aenv sh           -- index into the array-                -> PreOpenExp acc env aenv Int--  FromIndex     :: Shape sh-                => PreOpenExp acc env aenv sh           -- shape of the array-                -> PreOpenExp acc env aenv Int          -- index into linear representation-                -> PreOpenExp acc env aenv sh--  -- Conditional expression (non-strict in 2nd and 3rd argument)-  Cond          :: Elt t-                => PreOpenExp acc env aenv Bool-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv t--  -- Value recursion-  While         :: Elt a-                => PreOpenFun acc env aenv (a -> Bool)  -- continue while true-                -> PreOpenFun acc env aenv (a -> a)     -- function to iterate-                -> PreOpenExp acc env aenv a            -- initial value-                -> PreOpenExp acc env aenv a--  -- Constant values-  Const         :: Elt t-                => EltRepr t-                -> PreOpenExp acc env aenv t--  PrimConst     :: Elt t-                => PrimConst t-                -> PreOpenExp acc env aenv t--  -- Primitive scalar operations-  PrimApp       :: (Elt a, Elt r)-                => PrimFun (a -> r)-                -> PreOpenExp acc env aenv a-                -> PreOpenExp acc env aenv r--  -- Project a single scalar from an array.-  -- The array expression can not contain any free scalar variables.-  Index         :: (Shape dim, Elt t)-                => acc                aenv (Array dim t)-                -> PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv t--  LinearIndex   :: (Shape dim, Elt t)-                => acc                aenv (Array dim t)-                -> PreOpenExp acc env aenv Int-                -> PreOpenExp acc env aenv t--  -- Array shape.-  -- The array expression can not contain any free scalar variables.-  Shape         :: (Shape dim, Elt e)-                => acc                aenv (Array dim e)-                -> PreOpenExp acc env aenv dim--  -- Number of elements of an array given its shape-  ShapeSize     :: Shape dim-                => PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv Int--  -- Intersection of two shapes-  Intersect     :: Shape dim-                => PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv dim--  -- Union of two shapes-  Union         :: Shape dim-                => PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv dim--  -- Unsafe operations (may fail or result in undefined behaviour)-  -- An unspecified bit pattern-  Undef         :: Elt t-                => PreOpenExp acc env aenv t--  -- Reinterpret the bits of a value as a different type-  Coerce        :: (Elt a, Elt b)-                => PreOpenExp acc env aenv a-                -> PreOpenExp acc env aenv b----- |Primitive constant values----data PrimConst ty where--  -- constants from Bounded-  PrimMinBound  :: BoundedType a -> PrimConst a-  PrimMaxBound  :: BoundedType a -> PrimConst a--  -- constant from Floating-  PrimPi        :: FloatingType a -> PrimConst a---- |Primitive scalar operations----data PrimFun sig where--  -- operators from Num-  PrimAdd  :: NumType a -> PrimFun ((a, a) -> a)-  PrimSub  :: NumType a -> PrimFun ((a, a) -> a)-  PrimMul  :: NumType a -> PrimFun ((a, a) -> a)-  PrimNeg  :: NumType a -> PrimFun (a      -> a)-  PrimAbs  :: NumType a -> PrimFun (a      -> a)-  PrimSig  :: NumType a -> PrimFun (a      -> a)--  -- operators from Integral-  PrimQuot     :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimRem      :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimQuotRem  :: IntegralType a -> PrimFun ((a, a)   -> (a, a))-  PrimIDiv     :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimMod      :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimDivMod   :: IntegralType a -> PrimFun ((a, a)   -> (a, a))--  -- operators from Bits & FiniteBits-  PrimBAnd               :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBOr                :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBXor               :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBNot               :: IntegralType a -> PrimFun (a        -> a)-  PrimBShiftL            :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBShiftR            :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBRotateL           :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBRotateR           :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimPopCount           :: IntegralType a -> PrimFun (a -> Int)-  PrimCountLeadingZeros  :: IntegralType a -> PrimFun (a -> Int)-  PrimCountTrailingZeros :: IntegralType a -> PrimFun (a -> Int)--  -- operators from Fractional and Floating-  PrimFDiv        :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimRecip       :: FloatingType a -> PrimFun (a      -> a)-  PrimSin         :: FloatingType a -> PrimFun (a      -> a)-  PrimCos         :: FloatingType a -> PrimFun (a      -> a)-  PrimTan         :: FloatingType a -> PrimFun (a      -> a)-  PrimAsin        :: FloatingType a -> PrimFun (a      -> a)-  PrimAcos        :: FloatingType a -> PrimFun (a      -> a)-  PrimAtan        :: FloatingType a -> PrimFun (a      -> a)-  PrimSinh        :: FloatingType a -> PrimFun (a      -> a)-  PrimCosh        :: FloatingType a -> PrimFun (a      -> a)-  PrimTanh        :: FloatingType a -> PrimFun (a      -> a)-  PrimAsinh       :: FloatingType a -> PrimFun (a      -> a)-  PrimAcosh       :: FloatingType a -> PrimFun (a      -> a)-  PrimAtanh       :: FloatingType a -> PrimFun (a      -> a)-  PrimExpFloating :: FloatingType a -> PrimFun (a      -> a)-  PrimSqrt        :: FloatingType a -> PrimFun (a      -> a)-  PrimLog         :: FloatingType a -> PrimFun (a      -> a)-  PrimFPow        :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimLogBase     :: FloatingType a -> PrimFun ((a, a) -> a)--  -- FIXME: add missing operations from RealFrac & RealFloat--  -- operators from RealFrac-  PrimTruncate :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimRound    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimFloor    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimCeiling  :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  -- PrimProperFraction :: FloatingType a -> IntegralType b -> PrimFun (a -> (b, a))--  -- operators from RealFloat-  PrimAtan2          :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimIsNaN          :: FloatingType a -> PrimFun (a -> Bool)-  PrimIsInfinite     :: FloatingType a -> PrimFun (a -> Bool)--  -- relational and equality operators-  PrimLt   :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimGt   :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimLtEq :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimGtEq :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimEq   :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimNEq  :: SingleType a -> PrimFun ((a, a) -> Bool)-  PrimMax  :: SingleType a -> PrimFun ((a, a) -> a   )-  PrimMin  :: SingleType a -> PrimFun ((a, a) -> a   )--  -- logical operators-  PrimLAnd :: PrimFun ((Bool, Bool) -> Bool)-  PrimLOr  :: PrimFun ((Bool, Bool) -> Bool)-  PrimLNot :: PrimFun (Bool         -> Bool)--  -- character conversions-  PrimOrd  :: PrimFun (Char -> Int)-  PrimChr  :: PrimFun (Int  -> Char)--  -- boolean conversion-  PrimBoolToInt :: PrimFun (Bool -> Int)--  -- general conversion between types-  PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b)-  PrimToFloating   :: NumType a -> FloatingType b -> PrimFun (a -> b)----- NFData instances--- ================--instance NFData (OpenAfun aenv f) where-  rnf = rnfOpenAfun--instance NFData (OpenAcc aenv t) where-  rnf = rnfOpenAcc---- instance NFData (Seq t) where---   rnf = rnfPreOpenSeq rnfOpenAcc--instance NFData (OpenExp env aenv t) where-  rnf = rnfPreOpenExp rnfOpenAcc--instance NFData (OpenFun env aenv t) where-  rnf = rnfPreOpenFun rnfOpenAcc----- Array expressions--- -------------------type NFDataAcc acc = forall aenv t. acc aenv t -> ()--rnfIdx :: Idx env t -> ()-rnfIdx ZeroIdx      = ()-rnfIdx (SuccIdx ix) = rnfIdx ix--rnfTupleIdx :: TupleIdx t e -> ()-rnfTupleIdx ZeroTupIdx       = ()-rnfTupleIdx (SuccTupIdx tix) = rnfTupleIdx tix--rnfOpenAfun :: OpenAfun aenv t -> ()-rnfOpenAfun = rnfPreOpenAfun rnfOpenAcc--rnfOpenAcc :: OpenAcc aenv t -> ()-rnfOpenAcc (OpenAcc pacc) = rnfPreOpenAcc rnfOpenAcc pacc--rnfPreOpenAfun :: NFDataAcc acc -> PreOpenAfun acc aenv t -> ()-rnfPreOpenAfun rnfA (Abody b) = rnfA b-rnfPreOpenAfun rnfA (Alam f)  = rnfPreOpenAfun rnfA f--rnfPreOpenAcc :: forall acc aenv t. NFDataAcc acc -> PreOpenAcc acc aenv t -> ()-rnfPreOpenAcc rnfA pacc =-  let-      rnfAF :: PreOpenAfun acc aenv' t' -> ()-      rnfAF = rnfPreOpenAfun rnfA--      rnfE :: PreOpenExp acc env' aenv' t' -> ()-      rnfE = rnfPreOpenExp rnfA--      rnfF :: PreOpenFun acc env' aenv' t' -> ()-      rnfF = rnfPreOpenFun rnfA--      -- rnfS :: PreOpenSeq acc aenv' senv' t' -> ()-      -- rnfS = rnfPreOpenSeq rnfA--      rnfB :: PreBoundary acc aenv' (Array sh e) -> ()-      rnfB = rnfBoundary rnfA-  in-  case pacc of-    Alet bnd body             -> rnfA bnd `seq` rnfA body-    Avar ix                   -> rnfIdx ix-    Atuple atup               -> rnfAtuple rnfA atup-    Aprj tix a                -> rnfTupleIdx tix `seq` rnfA a-    Apply afun acc            -> rnfAF afun `seq` rnfA acc-    Aforeign asm afun a       -> rnf (strForeign asm) `seq` rnfAF afun `seq` rnfA a-    Acond p a1 a2             -> rnfE p `seq` rnfA a1 `seq` rnfA a2-    Awhile p f a              -> rnfAF p `seq` rnfAF f `seq` rnfA a-    Use arrs                  -> rnfArrays (arrays (undefined::t)) arrs-    Unit x                    -> rnfE x-    Reshape sh a              -> rnfE sh `seq` rnfA a-    Generate sh f             -> rnfE sh `seq` rnfF f-    Transform sh p f a        -> rnfE sh `seq` rnfF p `seq` rnfF f `seq` rnfA a-    Replicate slice sh a      -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a-    Slice slice a sh          -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a-    Map f a                   -> rnfF f `seq` rnfA a-    ZipWith f a1 a2           -> rnfF f `seq` rnfA a1 `seq` rnfA a2-    Fold f z a                -> rnfF f `seq` rnfE z `seq` rnfA a-    Fold1 f a                 -> rnfF f `seq` rnfA a-    FoldSeg f z a s           -> rnfF f `seq` rnfE z `seq` rnfA a `seq` rnfA s-    Fold1Seg f a s            -> rnfF f `seq` rnfA a `seq` rnfA s-    Scanl f z a               -> rnfF f `seq` rnfE z `seq` rnfA a-    Scanl1 f a                -> rnfF f `seq` rnfA a-    Scanl' f z a              -> rnfF f `seq` rnfE z `seq` rnfA a-    Scanr f z a               -> rnfF f `seq` rnfE z `seq` rnfA a-    Scanr1 f a                -> rnfF f `seq` rnfA a-    Scanr' f z a              -> rnfF f `seq` rnfE z `seq` rnfA a-    Permute f d p a           -> rnfF f `seq` rnfA d `seq` rnfF p `seq` rnfA a-    Backpermute sh f a        -> rnfE sh `seq` rnfF f `seq` rnfA a-    Stencil f b a             -> rnfF f `seq` rnfB b  `seq` rnfA a-    Stencil2 f b1 a1 b2 a2    -> rnfF f `seq` rnfB b1 `seq` rnfB b2 `seq` rnfA a1 `seq` rnfA a2-    -- Collect s                 -> rnfS s---rnfAtuple :: NFDataAcc acc -> Atuple (acc aenv) t -> ()-rnfAtuple _    NilAtup          = ()-rnfAtuple rnfA (SnocAtup tup a) = rnfAtuple rnfA tup `seq` rnfA a--rnfArrays :: ArraysR arrs -> arrs -> ()-rnfArrays ArraysRunit           ()      = ()-rnfArrays ArraysRarray          arr     = rnf arr-rnfArrays (ArraysRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2--rnfBoundary :: forall acc aenv sh e. NFDataAcc acc -> PreBoundary acc aenv (Array sh e) -> ()-rnfBoundary _    Clamp        = ()-rnfBoundary _    Mirror       = ()-rnfBoundary _    Wrap         = ()-rnfBoundary _    (Constant c) = rnfConst (eltType (undefined::e)) c-rnfBoundary rnfA (Function f) = rnfPreOpenFun rnfA f---{----- Sequence expressions--- ----------------------rnfPreOpenSeq :: forall acc aenv senv t. NFDataAcc acc -> PreOpenSeq acc aenv senv t -> ()-rnfPreOpenSeq rnfA topSeq =-  let-      rnfS :: PreOpenSeq acc aenv' senv' t' -> ()-      rnfS = rnfPreOpenSeq rnfA--      rnfP :: Producer acc aenv' senv' t' -> ()-      rnfP = rnfSeqProducer rnfA--      rnfC :: Consumer acc aenv' senv' t' -> ()-      rnfC = rnfSeqConsumer rnfA-  in-  case topSeq of-    Producer p s              -> rnfP p `seq` rnfS s-    Consumer c                -> rnfC c-    Reify ix                  -> rnfIdx ix--rnfSeqProducer :: forall acc aenv senv t. NFDataAcc acc -> Producer acc aenv senv t -> ()-rnfSeqProducer rnfA topSeq =-  let-      rnfArrs :: forall a. Arrays a => [a] -> ()-      rnfArrs []     = ()-      rnfArrs (a:as) = rnfArrays (arrays (undefined::a)) (fromArr a) `seq` rnfArrs as--      rnfAF :: PreOpenAfun acc aenv' t' -> ()-      rnfAF = rnfPreOpenAfun rnfA--      rnfF :: PreOpenFun acc env' aenv' t' -> ()-      rnfF = rnfPreOpenFun rnfA--      rnfE :: PreOpenExp acc env' aenv' t' -> ()-      rnfE = rnfPreOpenExp rnfA-  in-  case topSeq of-    StreamIn as               -> rnfArrs as-    ToSeq slice _ a           -> rnfSliceIndex slice `seq` rnfA a-    MapSeq f ix               -> rnfAF f `seq` rnfIdx ix-    ChunkedMapSeq f ix        -> rnfAF f `seq` rnfIdx ix-    ZipWithSeq f ix1 ix2      -> rnfAF f `seq` rnfIdx ix1 `seq` rnfIdx ix2-    ScanSeq f z ix            -> rnfF f `seq` rnfE z `seq` rnfIdx ix--rnfSeqConsumer :: forall acc aenv senv t. NFDataAcc acc -> Consumer acc aenv senv t -> ()-rnfSeqConsumer rnfA topSeq =-  let-      rnfAF :: PreOpenAfun acc aenv' t' -> ()-      rnfAF = rnfPreOpenAfun rnfA--      rnfF :: PreOpenFun acc env' aenv' t' -> ()-      rnfF = rnfPreOpenFun rnfA--      rnfE :: PreOpenExp acc env' aenv' t' -> ()-      rnfE = rnfPreOpenExp rnfA-  in-  case topSeq of-    FoldSeq f z ix            -> rnfF f `seq` rnfE z `seq` rnfIdx ix-    FoldSeqFlatten f a ix     -> rnfAF f `seq` rnfA a `seq` rnfIdx ix-    Stuple stup               -> rnfStuple rnfA stup--rnfStuple :: NFDataAcc acc -> Atuple (Consumer acc aenv senv) t -> ()-rnfStuple _    NilAtup          = ()-rnfStuple rnfA (SnocAtup tup c) = rnfStuple rnfA tup `seq` rnfSeqConsumer rnfA c---}---- Scalar expressions--- --------------------rnfPreOpenFun :: NFDataAcc acc -> PreOpenFun acc env aenv t -> ()-rnfPreOpenFun rnfA (Body b) = rnfPreOpenExp rnfA b-rnfPreOpenFun rnfA (Lam f)  = rnfPreOpenFun rnfA f--rnfPreOpenExp :: forall acc env aenv t. NFDataAcc acc -> PreOpenExp acc env aenv t -> ()-rnfPreOpenExp rnfA topExp =-  let-      rnfF :: PreOpenFun acc env' aenv' t' -> ()-      rnfF = rnfPreOpenFun rnfA--      rnfE :: PreOpenExp acc env' aenv' t' -> ()-      rnfE = rnfPreOpenExp rnfA-  in-  case topExp of-    Let bnd body              -> rnfE bnd `seq` rnfE body-    Var ix                    -> rnfIdx ix-    Foreign asm f x           -> rnf (strForeign asm) `seq` rnfF f `seq` rnfE x-    Const t                   -> rnfConst (eltType (undefined::t)) t-    Undef                     -> ()-    Tuple t                   -> rnfTuple rnfA t-    Prj ix e                  -> rnfTupleIdx ix `seq` rnfE e-    IndexNil                  -> ()-    IndexCons sh sz           -> rnfE sh `seq` rnfE sz-    IndexHead sh              -> rnfE sh-    IndexTail sh              -> rnfE sh-    IndexAny                  -> ()-    IndexSlice slice slix sh  -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sh-    IndexFull slice slix sl   -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sl-    ToIndex sh ix             -> rnfE sh `seq` rnfE ix-    FromIndex sh ix           -> rnfE sh `seq` rnfE ix-    Cond p e1 e2              -> rnfE p `seq` rnfE e1 `seq` rnfE e2-    While p f x               -> rnfF p `seq` rnfF f `seq` rnfE x-    PrimConst c               -> rnfPrimConst c-    PrimApp f x               -> rnfPrimFun f `seq` rnfE x-    Index a ix                -> rnfA a `seq` rnfE ix-    LinearIndex a ix          -> rnfA a `seq` rnfE ix-    Shape a                   -> rnfA a-    ShapeSize sh              -> rnfE sh-    Intersect sh1 sh2         -> rnfE sh1 `seq` rnfE sh2-    Union sh1 sh2             -> rnfE sh1 `seq` rnfE sh2-    Coerce e                  -> rnfE e--rnfTuple :: NFDataAcc acc -> Tuple (PreOpenExp acc env aenv) t -> ()-rnfTuple _    NilTup        = ()-rnfTuple rnfA (SnocTup t e) = rnfTuple rnfA t `seq` rnfPreOpenExp rnfA e--rnfConst :: TupleType t -> t -> ()-rnfConst TypeRunit          ()    = ()-rnfConst (TypeRscalar t)    !_    = rnfScalarType t  -- scalars should have (nf == whnf)-rnfConst (TypeRpair ta tb)  (a,b) = rnfConst ta a `seq` rnfConst tb b--rnfPrimConst :: PrimConst c -> ()-rnfPrimConst (PrimMinBound t) = rnfBoundedType t-rnfPrimConst (PrimMaxBound t) = rnfBoundedType t-rnfPrimConst (PrimPi t)       = rnfFloatingType t--rnfPrimFun :: PrimFun f -> ()-rnfPrimFun (PrimAdd t)                = rnfNumType t-rnfPrimFun (PrimSub t)                = rnfNumType t-rnfPrimFun (PrimMul t)                = rnfNumType t-rnfPrimFun (PrimNeg t)                = rnfNumType t-rnfPrimFun (PrimAbs t)                = rnfNumType t-rnfPrimFun (PrimSig t)                = rnfNumType t-rnfPrimFun (PrimQuot t)               = rnfIntegralType t-rnfPrimFun (PrimRem t)                = rnfIntegralType t-rnfPrimFun (PrimQuotRem t)            = rnfIntegralType t-rnfPrimFun (PrimIDiv t)               = rnfIntegralType t-rnfPrimFun (PrimMod t)                = rnfIntegralType t-rnfPrimFun (PrimDivMod t)             = rnfIntegralType t-rnfPrimFun (PrimBAnd t)               = rnfIntegralType t-rnfPrimFun (PrimBOr t)                = rnfIntegralType t-rnfPrimFun (PrimBXor t)               = rnfIntegralType t-rnfPrimFun (PrimBNot t)               = rnfIntegralType t-rnfPrimFun (PrimBShiftL t)            = rnfIntegralType t-rnfPrimFun (PrimBShiftR t)            = rnfIntegralType t-rnfPrimFun (PrimBRotateL t)           = rnfIntegralType t-rnfPrimFun (PrimBRotateR t)           = rnfIntegralType t-rnfPrimFun (PrimPopCount t)           = rnfIntegralType t-rnfPrimFun (PrimCountLeadingZeros t)  = rnfIntegralType t-rnfPrimFun (PrimCountTrailingZeros t) = rnfIntegralType t-rnfPrimFun (PrimFDiv t)               = rnfFloatingType t-rnfPrimFun (PrimRecip t)              = rnfFloatingType t-rnfPrimFun (PrimSin t)                = rnfFloatingType t-rnfPrimFun (PrimCos t)                = rnfFloatingType t-rnfPrimFun (PrimTan t)                = rnfFloatingType t-rnfPrimFun (PrimAsin t)               = rnfFloatingType t-rnfPrimFun (PrimAcos t)               = rnfFloatingType t-rnfPrimFun (PrimAtan t)               = rnfFloatingType t-rnfPrimFun (PrimSinh t)               = rnfFloatingType t-rnfPrimFun (PrimCosh t)               = rnfFloatingType t-rnfPrimFun (PrimTanh t)               = rnfFloatingType t-rnfPrimFun (PrimAsinh t)              = rnfFloatingType t-rnfPrimFun (PrimAcosh t)              = rnfFloatingType t-rnfPrimFun (PrimAtanh t)              = rnfFloatingType t-rnfPrimFun (PrimExpFloating t)        = rnfFloatingType t-rnfPrimFun (PrimSqrt t)               = rnfFloatingType t-rnfPrimFun (PrimLog t)                = rnfFloatingType t-rnfPrimFun (PrimFPow t)               = rnfFloatingType t-rnfPrimFun (PrimLogBase t)            = rnfFloatingType t-rnfPrimFun (PrimTruncate f i)         = rnfFloatingType f `seq` rnfIntegralType i-rnfPrimFun (PrimRound f i)            = rnfFloatingType f `seq` rnfIntegralType i-rnfPrimFun (PrimFloor f i)            = rnfFloatingType f `seq` rnfIntegralType i-rnfPrimFun (PrimCeiling f i)          = rnfFloatingType f `seq` rnfIntegralType i-rnfPrimFun (PrimIsNaN t)              = rnfFloatingType t-rnfPrimFun (PrimIsInfinite t)         = rnfFloatingType t-rnfPrimFun (PrimAtan2 t)              = rnfFloatingType t-rnfPrimFun (PrimLt t)                 = rnfSingleType t-rnfPrimFun (PrimGt t)                 = rnfSingleType t-rnfPrimFun (PrimLtEq t)               = rnfSingleType t-rnfPrimFun (PrimGtEq t)               = rnfSingleType t-rnfPrimFun (PrimEq t)                 = rnfSingleType t-rnfPrimFun (PrimNEq t)                = rnfSingleType t-rnfPrimFun (PrimMax t)                = rnfSingleType t-rnfPrimFun (PrimMin t)                = rnfSingleType t-rnfPrimFun PrimLAnd                   = ()-rnfPrimFun PrimLOr                    = ()-rnfPrimFun PrimLNot                   = ()-rnfPrimFun PrimOrd                    = ()-rnfPrimFun PrimChr                    = ()-rnfPrimFun PrimBoolToInt              = ()-rnfPrimFun (PrimFromIntegral i n)     = rnfIntegralType i `seq` rnfNumType n-rnfPrimFun (PrimToFloating n f)       = rnfNumType n `seq` rnfFloatingType f--rnfSliceIndex :: SliceIndex ix slice co sh -> ()-rnfSliceIndex SliceNil        = ()-rnfSliceIndex (SliceAll sh)   = rnfSliceIndex sh-rnfSliceIndex (SliceFixed sh) = rnfSliceIndex sh--rnfScalarType :: ScalarType t -> ()-rnfScalarType (SingleScalarType t) = rnfSingleType t-rnfScalarType (VectorScalarType t) = rnfVectorType t--rnfSingleType :: SingleType t -> ()-rnfSingleType (NumSingleType t)    = rnfNumType t-rnfSingleType (NonNumSingleType t) = rnfNonNumType t--rnfVectorType :: VectorType t -> ()-rnfVectorType (Vector2Type t)  = rnfSingleType t-rnfVectorType (Vector3Type t)  = rnfSingleType t-rnfVectorType (Vector4Type t)  = rnfSingleType t-rnfVectorType (Vector8Type t)  = rnfSingleType t-rnfVectorType (Vector16Type t) = rnfSingleType t--rnfBoundedType :: BoundedType t -> ()-rnfBoundedType (IntegralBoundedType t) = rnfIntegralType t-rnfBoundedType (NonNumBoundedType t)   = rnfNonNumType t--rnfNumType :: NumType t -> ()-rnfNumType (IntegralNumType t) = rnfIntegralType t-rnfNumType (FloatingNumType t) = rnfFloatingType t--rnfNonNumType :: NonNumType t -> ()-rnfNonNumType (TypeBool   NonNumDict) = ()-rnfNonNumType (TypeChar   NonNumDict) = ()-rnfNonNumType (TypeCChar  NonNumDict) = ()-rnfNonNumType (TypeCSChar NonNumDict) = ()-rnfNonNumType (TypeCUChar NonNumDict) = ()--rnfIntegralType :: IntegralType t -> ()-rnfIntegralType (TypeInt     IntegralDict) = ()-rnfIntegralType (TypeInt8    IntegralDict) = ()-rnfIntegralType (TypeInt16   IntegralDict) = ()-rnfIntegralType (TypeInt32   IntegralDict) = ()-rnfIntegralType (TypeInt64   IntegralDict) = ()-rnfIntegralType (TypeWord    IntegralDict) = ()-rnfIntegralType (TypeWord8   IntegralDict) = ()-rnfIntegralType (TypeWord16  IntegralDict) = ()-rnfIntegralType (TypeWord32  IntegralDict) = ()-rnfIntegralType (TypeWord64  IntegralDict) = ()-rnfIntegralType (TypeCShort  IntegralDict) = ()-rnfIntegralType (TypeCUShort IntegralDict) = ()-rnfIntegralType (TypeCInt    IntegralDict) = ()-rnfIntegralType (TypeCUInt   IntegralDict) = ()-rnfIntegralType (TypeCLong   IntegralDict) = ()-rnfIntegralType (TypeCULong  IntegralDict) = ()-rnfIntegralType (TypeCLLong  IntegralDict) = ()-rnfIntegralType (TypeCULLong IntegralDict) = ()--rnfFloatingType :: FloatingType t -> ()-rnfFloatingType (TypeHalf    FloatingDict) = ()-rnfFloatingType (TypeFloat   FloatingDict) = ()-rnfFloatingType (TypeDouble  FloatingDict) = ()-rnfFloatingType (TypeCFloat  FloatingDict) = ()-rnfFloatingType (TypeCDouble FloatingDict) = ()----- Template Haskell--- ================--type LiftAcc acc = forall aenv a. acc aenv a -> Q (TExp (acc aenv a))--liftIdx :: Idx env t -> Q (TExp (Idx env t))-liftIdx ZeroIdx      = [|| ZeroIdx ||]-liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||]--liftTupleIdx :: TupleIdx t e -> Q (TExp (TupleIdx t e))-liftTupleIdx ZeroTupIdx       = [|| ZeroTupIdx ||]-liftTupleIdx (SuccTupIdx tix) = [|| SuccTupIdx $$(liftTupleIdx tix) ||]---liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t))-liftPreOpenAfun liftA (Alam f)  = [|| Alam  $$(liftPreOpenAfun liftA f) ||]-liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||]--liftPreOpenAcc-    :: forall acc aenv a.-       LiftAcc acc-    -> PreOpenAcc acc aenv a-    -> Q (TExp (PreOpenAcc acc aenv a))-liftPreOpenAcc liftA pacc =-  let-      liftE :: PreOpenExp acc env aenv t -> Q (TExp (PreOpenExp acc env aenv t))-      liftE = liftPreOpenExp liftA--      liftF :: PreOpenFun acc env aenv t -> Q (TExp (PreOpenFun acc env aenv t))-      liftF = liftPreOpenFun liftA--      liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f))-      liftAF = liftPreOpenAfun liftA--      liftB :: PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e)))-      liftB = liftBoundary liftA--      liftAtuple :: Atuple (acc aenv) t -> Q (TExp (Atuple (acc aenv) t))-      liftAtuple NilAtup          = [|| NilAtup ||]-      liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||]-  in-  case pacc of-    Alet bnd body             -> [|| Alet $$(liftA bnd) $$(liftA body) ||]-    Avar ix                   -> [|| Avar $$(liftIdx ix) ||]-    Atuple tup                -> [|| Atuple $$(liftAtuple tup) ||]-    Aprj tix a                -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||]-    Apply f a                 -> [|| Apply $$(liftAF f) $$(liftA a) ||]-    Aforeign asm f a          -> [|| Aforeign $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||]-    Acond p t e               -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]-    Awhile p f a              -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]-    Use a                     -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||]-    Unit e                    -> [|| Unit $$(liftE e) ||]-    Reshape sh a              -> [|| Reshape $$(liftE sh) $$(liftA a) ||]-    Generate sh f             -> [|| Generate $$(liftE sh) $$(liftF f) ||]-    Transform sh p f a        -> [|| Transform $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||]-    Replicate slix sl a       -> [|| Replicate $$(liftSliceIndex slix) $$(liftE sl) $$(liftA a) ||]-    Slice slix a sh           -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||]-    Map f a                   -> [|| Map $$(liftF f) $$(liftA a) ||]-    ZipWith f a b             -> [|| ZipWith $$(liftF f) $$(liftA a) $$(liftA b) ||]-    Fold f z a                -> [|| Fold $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Fold1 f a                 -> [|| Fold1 $$(liftF f) $$(liftA a) ||]-    FoldSeg f z a s           -> [|| FoldSeg $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||]-    Fold1Seg f a s            -> [|| Fold1Seg $$(liftF f) $$(liftA a) $$(liftA s) ||]-    Scanl f z a               -> [|| Scanl $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanl1 f a                -> [|| Scanl1 $$(liftF f) $$(liftA a) ||]-    Scanl' f z a              -> [|| Scanl' $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanr f z a               -> [|| Scanr $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanr1 f a                -> [|| Scanr1 $$(liftF f) $$(liftA a) ||]-    Scanr' f z a              -> [|| Scanr' $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Permute f d p a           -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||]-    Backpermute sh p a        -> [|| Backpermute $$(liftE sh) $$(liftF p) $$(liftA a) ||]-    Stencil f b a             -> [|| Stencil $$(liftF f) $$(liftB b) $$(liftA a) ||]-    Stencil2 f b1 a1 b2 a2    -> [|| Stencil2 $$(liftF f) $$(liftB b1) $$(liftA a1) $$(liftB b2) $$(liftA a2) ||]---liftPreOpenFun-    :: LiftAcc acc-    -> PreOpenFun acc env aenv t-    -> Q (TExp (PreOpenFun acc env aenv t))-liftPreOpenFun liftA (Lam f)  = [|| Lam  $$(liftPreOpenFun liftA f) ||]-liftPreOpenFun liftA (Body b) = [|| Body $$(liftPreOpenExp liftA b) ||]--liftPreOpenExp-    :: forall acc env aenv t.-       LiftAcc acc-    -> PreOpenExp acc env aenv t-    -> Q (TExp (PreOpenExp acc env aenv t))-liftPreOpenExp liftA pexp =-  let-      liftE :: PreOpenExp acc env aenv e -> Q (TExp (PreOpenExp acc env aenv e))-      liftE = liftPreOpenExp liftA--      liftF :: PreOpenFun acc env aenv f -> Q (TExp (PreOpenFun acc env aenv f))-      liftF = liftPreOpenFun liftA--      liftT :: Tuple (PreOpenExp acc env aenv) e -> Q (TExp (Tuple (PreOpenExp acc env aenv) e))-      liftT NilTup          = [|| NilTup ||]-      liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||]-  in-  case pexp of-    Let bnd body              -> [|| Let $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||]-    Var ix                    -> [|| Var $$(liftIdx ix) ||]-    Foreign asm f x           -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA 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  -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||]-    IndexFull slice slix sl   -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||]-    ToIndex sh ix             -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||]-    FromIndex sh ix           -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||]-    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 e                  -> [|| Coerce $$(liftE e) ||]---liftArrays :: ArraysR arr -> arr -> Q (TExp arr)-liftArrays ArraysRunit ()              = [|| () ||]-liftArrays ArraysRarray arr            = [|| $$(liftArray arr) ||]-liftArrays (ArraysRpair r1 r2) (a1,a2) = [|| ($$(liftArrays r1 a1), $$(liftArrays r2 a2)) ||]--liftArray :: forall sh e. Array sh e -> Q (TExp (Array sh e))-liftArray (Array sh adata) =-  [|| Array $$(liftConst (eltType (undefined::sh)) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e))-  where-    sz :: Int-    sz = size sh--    sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t)-    sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t--    typeRepToType :: TypeRep -> Q TH.Type-    typeRepToType trep = do-      let (con, args)     = splitTyConApp trep-          name            = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con)))-          ---          appsT x []      = x-          appsT x (y:xs)  = appsT (TH.AppT x y) xs-          ---      resultArgs <- mapM typeRepToType args-      return (appsT (TH.ConT name) resultArgs)--    -- TODO: make sure that the resulting array is 16-byte aligned...-    arr :: forall a. (ArrayElt a, Storable a) => UniqueArray a -> Q (TExp (UniqueArray a))-    arr ua = do-      bytes <- TH.runIO $ peekArray (sizeOf (undefined::a) * sz) (castPtr (unsafeUniqueArrayPtr ua) :: Ptr Word8)-      [|| unsafePerformIO $ do-           fp  <- newForeignPtr_ $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |] )-           ua' <- newUniqueArray (castForeignPtr fp)-           return ua'-       ||]--    go :: ArrayEltR e' -> ArrayData e' -> Q (TExp (ArrayData e'))-    go ArrayEltRunit         AD_Unit         = [|| AD_Unit ||]-    go ArrayEltRint          (AD_Int ua)     = [|| AD_Int $$(arr ua) ||]-    go ArrayEltRint8         (AD_Int8 ua)    = [|| AD_Int8 $$(arr ua) ||]-    go ArrayEltRint16        (AD_Int16 ua)   = [|| AD_Int16 $$(arr ua) ||]-    go ArrayEltRint32        (AD_Int32 ua)   = [|| AD_Int32 $$(arr ua) ||]-    go ArrayEltRint64        (AD_Int64 ua)   = [|| AD_Int64 $$(arr ua) ||]-    go ArrayEltRword         (AD_Word ua)    = [|| AD_Word $$(arr ua) ||]-    go ArrayEltRword8        (AD_Word8 ua)   = [|| AD_Word8 $$(arr ua) ||]-    go ArrayEltRword16       (AD_Word16 ua)  = [|| AD_Word16 $$(arr ua) ||]-    go ArrayEltRword32       (AD_Word32 ua)  = [|| AD_Word32 $$(arr ua) ||]-    go ArrayEltRword64       (AD_Word64 ua)  = [|| AD_Word64 $$(arr ua) ||]-    go ArrayEltRcshort       (AD_CShort ua)  = [|| AD_CShort $$(arr ua) ||]-    go ArrayEltRcushort      (AD_CUShort ua) = [|| AD_CUShort $$(arr ua) ||]-    go ArrayEltRcint         (AD_CInt ua)    = [|| AD_CInt $$(arr ua) ||]-    go ArrayEltRcuint        (AD_CUInt ua)   = [|| AD_CUInt $$(arr ua) ||]-    go ArrayEltRclong        (AD_CLong ua)   = [|| AD_CLong $$(arr ua) ||]-    go ArrayEltRculong       (AD_CULong ua)  = [|| AD_CULong $$(arr ua) ||]-    go ArrayEltRcllong       (AD_CLLong ua)  = [|| AD_CLLong $$(arr ua) ||]-    go ArrayEltRcullong      (AD_CULLong ua) = [|| AD_CULLong $$(arr ua) ||]-    go ArrayEltRhalf         (AD_Half ua)    = [|| AD_Half $$(arr ua) ||]-    go ArrayEltRfloat        (AD_Float ua)   = [|| AD_Float $$(arr ua) ||]-    go ArrayEltRdouble       (AD_Double ua)  = [|| AD_Double $$(arr ua) ||]-    go ArrayEltRcfloat       (AD_CFloat ua)  = [|| AD_CFloat $$(arr ua) ||]-    go ArrayEltRcdouble      (AD_CDouble ua) = [|| AD_CDouble $$(arr ua) ||]-    go ArrayEltRbool         (AD_Bool ua)    = [|| AD_Bool $$(arr ua) ||]-    go ArrayEltRchar         (AD_Char ua)    = [|| AD_Char $$(arr ua) ||]-    go ArrayEltRcchar        (AD_CChar ua)   = [|| AD_CChar $$(arr ua) ||]-    go ArrayEltRcschar       (AD_CSChar ua)  = [|| AD_CSChar $$(arr ua) ||]-    go ArrayEltRcuchar       (AD_CUChar ua)  = [|| AD_CUChar $$(arr ua) ||]-    go (ArrayEltRvec2 r)     (AD_V2 a)       = [|| AD_V2 $$(go r a) ||]-    go (ArrayEltRvec3 r)     (AD_V3 a)       = [|| AD_V3 $$(go r a) ||]-    go (ArrayEltRvec4 r)     (AD_V4 a)       = [|| AD_V4 $$(go r a) ||]-    go (ArrayEltRvec8 r)     (AD_V8 a)       = [|| AD_V8 $$(go r a) ||]-    go (ArrayEltRvec16 r)    (AD_V16 a)      = [|| AD_V16 $$(go r a) ||]-    go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = [|| AD_Pair $$(go r1 a1) $$(go r2 a2) ||]---liftBoundary-    :: forall acc aenv sh e.-       LiftAcc acc-    -> PreBoundary acc aenv (Array sh e)-    -> Q (TExp (PreBoundary acc aenv (Array sh e)))-liftBoundary _     Clamp        = [|| Clamp ||]-liftBoundary _     Mirror       = [|| Mirror ||]-liftBoundary _     Wrap         = [|| Wrap ||]-liftBoundary _     (Constant v) = [|| Constant $$(liftConst (eltType (undefined::e)) v) ||]-liftBoundary liftA (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||]--liftSliceIndex :: SliceIndex ix slice coSlice sliceDim -> Q (TExp (SliceIndex ix slice coSlice sliceDim))-liftSliceIndex SliceNil          = [|| SliceNil ||]-liftSliceIndex (SliceAll rest)   = [|| SliceAll $$(liftSliceIndex rest) ||]-liftSliceIndex (SliceFixed rest) = [|| SliceFixed $$(liftSliceIndex rest) ||]--liftPrimConst :: PrimConst c -> Q (TExp (PrimConst c))-liftPrimConst (PrimMinBound t) = [|| PrimMinBound $$(liftBoundedType t) ||]-liftPrimConst (PrimMaxBound t) = [|| PrimMaxBound $$(liftBoundedType t) ||]-liftPrimConst (PrimPi t)       = [|| PrimPi $$(liftFloatingType t) ||]--liftPrimFun :: PrimFun f -> Q (TExp (PrimFun f))-liftPrimFun (PrimAdd t)                = [|| PrimAdd $$(liftNumType t) ||]-liftPrimFun (PrimSub t)                = [|| PrimSub $$(liftNumType t) ||]-liftPrimFun (PrimMul t)                = [|| PrimMul $$(liftNumType t) ||]-liftPrimFun (PrimNeg t)                = [|| PrimNeg $$(liftNumType t) ||]-liftPrimFun (PrimAbs t)                = [|| PrimAbs $$(liftNumType t) ||]-liftPrimFun (PrimSig t)                = [|| PrimSig $$(liftNumType t) ||]-liftPrimFun (PrimQuot t)               = [|| PrimQuot $$(liftIntegralType t) ||]-liftPrimFun (PrimRem t)                = [|| PrimRem $$(liftIntegralType t) ||]-liftPrimFun (PrimQuotRem t)            = [|| PrimQuotRem $$(liftIntegralType t) ||]-liftPrimFun (PrimIDiv t)               = [|| PrimIDiv $$(liftIntegralType t) ||]-liftPrimFun (PrimMod t)                = [|| PrimMod $$(liftIntegralType t) ||]-liftPrimFun (PrimDivMod t)             = [|| PrimDivMod $$(liftIntegralType t) ||]-liftPrimFun (PrimBAnd t)               = [|| PrimBAnd $$(liftIntegralType t) ||]-liftPrimFun (PrimBOr t)                = [|| PrimBOr $$(liftIntegralType t) ||]-liftPrimFun (PrimBXor t)               = [|| PrimBXor $$(liftIntegralType t) ||]-liftPrimFun (PrimBNot t)               = [|| PrimBNot $$(liftIntegralType t) ||]-liftPrimFun (PrimBShiftL t)            = [|| PrimBShiftL $$(liftIntegralType t) ||]-liftPrimFun (PrimBShiftR t)            = [|| PrimBShiftR $$(liftIntegralType t) ||]-liftPrimFun (PrimBRotateL t)           = [|| PrimBRotateL $$(liftIntegralType t) ||]-liftPrimFun (PrimBRotateR t)           = [|| PrimBRotateR $$(liftIntegralType t) ||]-liftPrimFun (PrimPopCount t)           = [|| PrimPopCount $$(liftIntegralType t) ||]-liftPrimFun (PrimCountLeadingZeros t)  = [|| PrimCountLeadingZeros $$(liftIntegralType t) ||]-liftPrimFun (PrimCountTrailingZeros t) = [|| PrimCountTrailingZeros $$(liftIntegralType t) ||]-liftPrimFun (PrimFDiv t)               = [|| PrimFDiv $$(liftFloatingType t) ||]-liftPrimFun (PrimRecip t)              = [|| PrimRecip $$(liftFloatingType t) ||]-liftPrimFun (PrimSin t)                = [|| PrimSin $$(liftFloatingType t) ||]-liftPrimFun (PrimCos t)                = [|| PrimCos $$(liftFloatingType t) ||]-liftPrimFun (PrimTan t)                = [|| PrimTan $$(liftFloatingType t) ||]-liftPrimFun (PrimAsin t)               = [|| PrimAsin $$(liftFloatingType t) ||]-liftPrimFun (PrimAcos t)               = [|| PrimAcos $$(liftFloatingType t) ||]-liftPrimFun (PrimAtan t)               = [|| PrimAtan $$(liftFloatingType t) ||]-liftPrimFun (PrimSinh t)               = [|| PrimSinh $$(liftFloatingType t) ||]-liftPrimFun (PrimCosh t)               = [|| PrimCosh $$(liftFloatingType t) ||]-liftPrimFun (PrimTanh t)               = [|| PrimTanh $$(liftFloatingType t) ||]-liftPrimFun (PrimAsinh t)              = [|| PrimAsinh $$(liftFloatingType t) ||]-liftPrimFun (PrimAcosh t)              = [|| PrimAcosh $$(liftFloatingType t) ||]-liftPrimFun (PrimAtanh t)              = [|| PrimAtanh $$(liftFloatingType t) ||]-liftPrimFun (PrimExpFloating t)        = [|| PrimExpFloating $$(liftFloatingType t) ||]-liftPrimFun (PrimSqrt t)               = [|| PrimSqrt $$(liftFloatingType t) ||]-liftPrimFun (PrimLog t)                = [|| PrimLog $$(liftFloatingType t) ||]-liftPrimFun (PrimFPow t)               = [|| PrimFPow $$(liftFloatingType t) ||]-liftPrimFun (PrimLogBase t)            = [|| PrimLogBase $$(liftFloatingType t) ||]-liftPrimFun (PrimTruncate ta tb)       = [|| PrimTruncate $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimRound ta tb)          = [|| PrimRound $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimFloor ta tb)          = [|| PrimFloor $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimCeiling ta tb)        = [|| PrimCeiling $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimIsNaN t)              = [|| PrimIsNaN $$(liftFloatingType t) ||]-liftPrimFun (PrimIsInfinite t)         = [|| PrimIsInfinite $$(liftFloatingType t) ||]-liftPrimFun (PrimAtan2 t)              = [|| PrimAtan2 $$(liftFloatingType t) ||]-liftPrimFun (PrimLt t)                 = [|| PrimLt $$(liftSingleType t) ||]-liftPrimFun (PrimGt t)                 = [|| PrimGt $$(liftSingleType t) ||]-liftPrimFun (PrimLtEq t)               = [|| PrimLtEq $$(liftSingleType t) ||]-liftPrimFun (PrimGtEq t)               = [|| PrimGtEq $$(liftSingleType t) ||]-liftPrimFun (PrimEq t)                 = [|| PrimEq $$(liftSingleType t) ||]-liftPrimFun (PrimNEq t)                = [|| PrimNEq $$(liftSingleType t) ||]-liftPrimFun (PrimMax t)                = [|| PrimMax $$(liftSingleType t) ||]-liftPrimFun (PrimMin t)                = [|| PrimMin $$(liftSingleType t) ||]-liftPrimFun PrimLAnd                   = [|| PrimLAnd ||]-liftPrimFun PrimLOr                    = [|| PrimLOr ||]-liftPrimFun PrimLNot                   = [|| PrimLNot ||]-liftPrimFun PrimOrd                    = [|| PrimOrd ||]-liftPrimFun PrimChr                    = [|| PrimChr ||]-liftPrimFun PrimBoolToInt              = [|| PrimBoolToInt ||]-liftPrimFun (PrimFromIntegral ta tb)   = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||]-liftPrimFun (PrimToFloating ta tb)     = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||]---liftConst :: TupleType t -> t -> Q (TExp t)-liftConst TypeRunit         ()    = [|| () ||]-liftConst (TypeRscalar t)   x     = [|| $$(liftScalar t x) ||]-liftConst (TypeRpair ta tb) (a,b) = [|| ($$(liftConst ta a), $$(liftConst tb b)) ||]--liftScalar :: ScalarType t -> t -> Q (TExp t)-liftScalar (SingleScalarType t) x = liftSingle t x-liftScalar (VectorScalarType t) x = liftVector t x--liftSingle :: SingleType t -> t -> Q (TExp t)-liftSingle (NumSingleType t)    x = liftNum t x-liftSingle (NonNumSingleType t) x = liftNonNum t x--liftVector :: VectorType v -> v -> Q (TExp v)-liftVector (Vector2Type t) (V2 a b)     = [|| V2 $$(liftSingle t a) $$(liftSingle t b) ||]-liftVector (Vector3Type t) (V3 a b c)   = [|| V3 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) ||]-liftVector (Vector4Type t) (V4 a b c d) = [|| V4 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d) ||]-liftVector (Vector8Type t) (V8 a b c d e f g h) =-  [|| V8 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d)-         $$(liftSingle t e) $$(liftSingle t f) $$(liftSingle t g) $$(liftSingle t h) ||]-liftVector (Vector16Type t) (V16 a b c d e f g h i j k l m n o p) =-  [|| V16 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d)-          $$(liftSingle t e) $$(liftSingle t f) $$(liftSingle t g) $$(liftSingle t h)-          $$(liftSingle t i) $$(liftSingle t j) $$(liftSingle t k) $$(liftSingle t l)-          $$(liftSingle t m) $$(liftSingle t n) $$(liftSingle t o) $$(liftSingle t p) ||]--liftNum :: NumType t -> t -> Q (TExp t)-liftNum (IntegralNumType t) x = liftIntegral t x-liftNum (FloatingNumType t) x = liftFloating t x--liftNonNum :: NonNumType t -> t -> Q (TExp t)-liftNonNum TypeBool{}   x = [|| x ||]-liftNonNum TypeChar{}   x = [|| x ||]-liftNonNum TypeCChar{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftNonNum TypeCSChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftNonNum TypeCUChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))--liftIntegral :: IntegralType t -> t -> Q (TExp t)-liftIntegral TypeInt{}     x = [|| x ||]-liftIntegral TypeInt8{}    x = [|| x ||]-liftIntegral TypeInt16{}   x = [|| x ||]-liftIntegral TypeInt32{}   x = [|| x ||]-liftIntegral TypeInt64{}   x = [|| x ||]-#if __GLASGOW_HASKELL__ >= 710-liftIntegral TypeWord{}    x = [|| x ||]-#else-liftIntegral TypeWord{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-#endif-liftIntegral TypeWord8{}   x = [|| x ||]-liftIntegral TypeWord16{}  x = [|| x ||]-liftIntegral TypeWord32{}  x = [|| x ||]-liftIntegral TypeWord64{}  x = [|| x ||]-liftIntegral TypeCShort{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCUShort{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCInt{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCUInt{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCLong{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCULong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCLLong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCULLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))--liftFloating :: FloatingType t -> t -> Q (TExp t)-liftFloating TypeHalf{}    x = [|| Half $$( liftIntegral integralType (getHalf x)) ||]-liftFloating TypeFloat{}   x = [|| x ||]-liftFloating TypeDouble{}  x = [|| x ||]-liftFloating TypeCFloat{}  x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))-liftFloating TypeCDouble{} x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))---liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t))-liftIntegralType TypeInt{}     = [|| TypeInt IntegralDict ||]-liftIntegralType TypeInt8{}    = [|| TypeInt8 IntegralDict ||]-liftIntegralType TypeInt16{}   = [|| TypeInt16 IntegralDict ||]-liftIntegralType TypeInt32{}   = [|| TypeInt32 IntegralDict ||]-liftIntegralType TypeInt64{}   = [|| TypeInt64 IntegralDict ||]-liftIntegralType TypeWord{}    = [|| TypeWord IntegralDict ||]-liftIntegralType TypeWord8{}   = [|| TypeWord8 IntegralDict ||]-liftIntegralType TypeWord16{}  = [|| TypeWord16 IntegralDict ||]-liftIntegralType TypeWord32{}  = [|| TypeWord32 IntegralDict ||]-liftIntegralType TypeWord64{}  = [|| TypeWord64 IntegralDict ||]-liftIntegralType TypeCShort{}  = [|| TypeCShort IntegralDict ||]-liftIntegralType TypeCUShort{} = [|| TypeCUShort IntegralDict ||]-liftIntegralType TypeCInt{}    = [|| TypeCInt IntegralDict ||]-liftIntegralType TypeCUInt{}   = [|| TypeCUInt IntegralDict ||]-liftIntegralType TypeCLong{}   = [|| TypeCLong IntegralDict ||]-liftIntegralType TypeCULong{}  = [|| TypeCULong IntegralDict ||]-liftIntegralType TypeCLLong{}  = [|| TypeCLLong IntegralDict ||]-liftIntegralType TypeCULLong{} = [|| TypeCULLong IntegralDict ||]--liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t))-liftFloatingType TypeHalf{}    = [|| TypeHalf FloatingDict ||]-liftFloatingType TypeFloat{}   = [|| TypeFloat FloatingDict ||]-liftFloatingType TypeDouble{}  = [|| TypeDouble FloatingDict ||]-liftFloatingType TypeCFloat{}  = [|| TypeCFloat FloatingDict ||]-liftFloatingType TypeCDouble{} = [|| TypeCDouble FloatingDict ||]--liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t))-liftNonNumType TypeBool{}   = [|| TypeBool NonNumDict ||]-liftNonNumType TypeChar{}   = [|| TypeChar NonNumDict ||]-liftNonNumType TypeCChar{}  = [|| TypeCChar NonNumDict ||]-liftNonNumType TypeCSChar{} = [|| TypeCSChar NonNumDict ||]-liftNonNumType TypeCUChar{} = [|| TypeCUChar NonNumDict ||]--liftNumType :: NumType t -> Q (TExp (NumType t))-liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||]-liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||]--liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t))-liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||]-liftBoundedType (NonNumBoundedType t)   = [|| NonNumBoundedType $$(liftNonNumType t) ||]---- liftScalarType :: ScalarType t -> Q (TExp (ScalarType t))--- liftScalarType (SingleScalarType t) = [|| SingleScalarType $$(liftSingleType t) ||]--- liftScalarType (VectorScalarType t) = [|| VectorScalarType $$(liftVectorType t) ||]--liftSingleType :: SingleType t -> Q (TExp (SingleType t))-liftSingleType (NumSingleType t)    = [|| NumSingleType $$(liftNumType t) ||]-liftSingleType (NonNumSingleType t) = [|| NonNumSingleType $$(liftNonNumType t) ||]---- liftVectorType :: VectorType t -> Q (TExp (VectorType t))--- liftVectorType (Vector2Type t)  = [|| Vector2Type $$(liftSingleType t) ||]--- liftVectorType (Vector3Type t)  = [|| Vector3Type $$(liftSingleType t) ||]--- liftVectorType (Vector4Type t)  = [|| Vector4Type $$(liftSingleType t) ||]--- liftVectorType (Vector8Type t)  = [|| Vector8Type $$(liftSingleType t) ||]--- liftVectorType (Vector16Type t) = [|| Vector16Type $$(liftSingleType t) ||]----- Debugging--- =========--showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String-showPreAccOp Alet{}             = "Alet"-showPreAccOp (Avar ix)          = "Avar a" ++ show (idxToInt ix)-showPreAccOp (Use a)            = "Use "  ++ showArrays (toArr a :: arrs)-showPreAccOp Apply{}            = "Apply"-showPreAccOp Aforeign{}         = "Aforeign"-showPreAccOp Acond{}            = "Acond"-showPreAccOp Awhile{}           = "Awhile"-showPreAccOp Atuple{}           = "Atuple"-showPreAccOp Aprj{}             = "Aprj"-showPreAccOp Unit{}             = "Unit"-showPreAccOp Generate{}         = "Generate"-showPreAccOp Transform{}        = "Transform"-showPreAccOp Reshape{}          = "Reshape"-showPreAccOp Replicate{}        = "Replicate"-showPreAccOp Slice{}            = "Slice"-showPreAccOp Map{}              = "Map"-showPreAccOp ZipWith{}          = "ZipWith"-showPreAccOp Fold{}             = "Fold"-showPreAccOp Fold1{}            = "Fold1"-showPreAccOp FoldSeg{}          = "FoldSeg"-showPreAccOp Fold1Seg{}         = "Fold1Seg"-showPreAccOp Scanl{}            = "Scanl"-showPreAccOp Scanl'{}           = "Scanl'"-showPreAccOp Scanl1{}           = "Scanl1"-showPreAccOp Scanr{}            = "Scanr"-showPreAccOp Scanr'{}           = "Scanr'"-showPreAccOp Scanr1{}           = "Scanr1"-showPreAccOp Permute{}          = "Permute"-showPreAccOp Backpermute{}      = "Backpermute"-showPreAccOp Stencil{}          = "Stencil"-showPreAccOp Stencil2{}         = "Stencil2"--- showPreAccOp Collect{}          = "Collect"--showArrays :: forall arrs. Arrays arrs => arrs -> String-showArrays = display . collect (arrays (undefined::arrs)) . fromArr-  where-    collect :: ArraysR a -> a -> [String]-    collect ArraysRunit         _        = []-    collect ArraysRarray        arr      = [showShortendArr arr]-    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2-    ---    display []  = []-    display [x] = x-    display xs  = "(" ++ intercalate ", " xs ++ ")"---showShortendArr :: Elt e => Array sh e -> String-showShortendArr arr-  = show (take cutoff l) ++ if length l > cutoff then ".." else ""-  where-    l      = toList arr-    cutoff = 5---showPreExpOp :: forall acc env aenv t. PreOpenExp acc env aenv t -> String-showPreExpOp Let{}              = "Let"-showPreExpOp (Var ix)           = "Var x" ++ show (idxToInt ix)-showPreExpOp (Const c)          = "Const " ++ show (toElt c :: t)-showPreExpOp Undef              = "Undef"-showPreExpOp Foreign{}          = "Foreign"-showPreExpOp Tuple{}            = "Tuple"-showPreExpOp Prj{}              = "Prj"-showPreExpOp IndexNil           = "IndexNil"-showPreExpOp IndexCons{}        = "IndexCons"-showPreExpOp IndexHead{}        = "IndexHead"-showPreExpOp IndexTail{}        = "IndexTail"-showPreExpOp IndexAny           = "IndexAny"-showPreExpOp IndexSlice{}       = "IndexSlice"-showPreExpOp IndexFull{}        = "IndexFull"-showPreExpOp ToIndex{}          = "ToIndex"-showPreExpOp FromIndex{}        = "FromIndex"-showPreExpOp Cond{}             = "Cond"-showPreExpOp While{}            = "While"-showPreExpOp PrimConst{}        = "PrimConst"-showPreExpOp PrimApp{}          = "PrimApp"-showPreExpOp Index{}            = "Index"-showPreExpOp LinearIndex{}      = "LinearIndex"-showPreExpOp Shape{}            = "Shape"-showPreExpOp ShapeSize{}        = "ShapeSize"-showPreExpOp Intersect{}        = "Intersect"-showPreExpOp Union{}            = "Union"-showPreExpOp Coerce{}           = "Coerce"+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- /Scalar versus collective operations/+--+-- The embedded array processing language is a two-level language.  It+-- combines a language of scalar expressions and functions with a language of+-- collective array operations.  Scalar expressions are used to compute+-- arguments for collective operations and scalar functions are used to+-- parametrise higher-order, collective array operations.  The two-level+-- structure, in particular, ensures that collective operations cannot be+-- parametrised with collective operations; hence, we are following a flat+-- data-parallel model.  The collective operations manipulate+-- multi-dimensional arrays whose shape is explicitly tracked in their types.+-- In fact, collective operations cannot produce any values other than+-- multi-dimensional arrays; when they yield a scalar, this is in the form of+-- a 0-dimensional, singleton array.  Similarly, scalar expression can -as+-- their name indicates- only produce tuples of scalar, but not arrays.+--+-- There are, however, two expression forms that take arrays as arguments.  As+-- a result scalar and array expressions are recursively dependent.  As we+-- cannot and don't want to compute arrays in the middle of scalar+-- computations, array computations will always be hoisted out of scalar+-- expressions.  So that this is always possible, these array expressions may+-- not contain any free scalar variables.  To express that condition in the+-- type structure, we use separate environments for scalar and array variables.+--+-- /Programs/+--+-- Collective array programs comprise closed expressions of array operations.+-- There is no explicit sharing in the initial AST form, but sharing is+-- introduced subsequently by common subexpression elimination and floating+-- of array computations.+--+-- /Functions/+--+-- The array expression language is first-order and only provides limited+-- control structures to ensure that it can be efficiently executed on+-- compute-acceleration hardware, such as GPUs.  To restrict functions to+-- first-order, we separate function abstraction from the main expression+-- type.  Functions are represented using de Bruijn indices.+--+-- /Parametric and ad-hoc polymorphism/+--+-- The array language features paramatric polymophism (e.g., pairing and+-- projections) as well as ad-hoc polymorphism (e.g., arithmetic operations).+-- All ad-hoc polymorphic constructs include reified dictionaries (c.f.,+-- module 'Types').  Reified dictionaries also ensure that constants+-- (constructor 'Const') are representable on compute acceleration hardware.+--+-- The AST contains both reified dictionaries and type class constraints.+-- Type classes are used for array-related functionality that is uniformly+-- available for all supported types.  In contrast, reified dictionaries are+-- used for functionality that is only available for certain types, such as+-- arithmetic operations.+--++module Data.Array.Accelerate.AST (++  -- * Internal AST+  -- ** Array computations+  Afun, PreAfun, OpenAfun, PreOpenAfun(..),+  Acc, OpenAcc(..), PreOpenAcc(..), Direction(..),+  ALeftHandSide, ArrayVar, ArrayVars,++  -- ** Scalar expressions+  ELeftHandSide, ExpVar, ExpVars, expVars,+  Fun, OpenFun(..),+  Exp, OpenExp(..),+  Boundary(..),+  PrimConst(..),+  PrimFun(..),+  PrimBool,+  PrimMaybe,++  -- ** Extracting type information+  HasArraysR(..), arrayR,+  expType,+  primConstType,+  primFunType,++  -- ** Normal-form+  NFDataAcc,+  rnfOpenAfun, rnfPreOpenAfun,+  rnfOpenAcc, rnfPreOpenAcc,+  rnfALeftHandSide,+  rnfArrayVar,+  rnfOpenFun,+  rnfOpenExp,+  rnfELeftHandSide,+  rnfExpVar,+  rnfBoundary,+  rnfConst,+  rnfPrimConst,+  rnfPrimFun,++  -- ** Template Haskell+  LiftAcc,+  liftPreOpenAfun,+  liftPreOpenAcc,+  liftALeftHandSide,+  liftArrayVar,+  liftOpenFun,+  liftOpenExp,+  liftELeftHandSide,+  liftExpVar,+  liftBoundary,+  liftPrimConst,+  liftPrimFun,++  -- ** Miscellaneous+  showPreAccOp,+  showExpOp,++) where++import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Slice+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Tag+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Vec+import Data.Array.Accelerate.Sugar.Foreign+import Data.Array.Accelerate.Type+import Data.Primitive.Vec++import Control.DeepSeq+import Data.Kind+import Language.Haskell.TH                                          ( Q, TExp )+import Prelude++import GHC.TypeLits+++-- Array expressions+-- -----------------++-- | Function abstraction over parametrised array computations+--+data PreOpenAfun acc aenv t where+  Abody ::                               acc             aenv  t -> PreOpenAfun acc aenv t+  Alam  :: ALeftHandSide a aenv aenv' -> PreOpenAfun acc aenv' t -> PreOpenAfun acc aenv (a -> t)++-- Function abstraction over vanilla open array computations+--+type OpenAfun = PreOpenAfun OpenAcc++-- | Parametrised array-computation function without free array variables+--+type PreAfun acc = PreOpenAfun acc ()++-- | Vanilla array-computation function without free array variables+--+type Afun = OpenAfun ()++-- Vanilla open array computations+--+newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t)++-- | Closed array expression aka an array program+--+type Acc = OpenAcc ()++-- Types for array binders+--+type ALeftHandSide  = LeftHandSide ArrayR+type ArrayVar       = Var ArrayR+type ArrayVars aenv = Vars ArrayR aenv++-- Bool is not a primitive type+type PrimBool    = TAG+type PrimMaybe a = (TAG, ((), a))+++-- | Collective array computations parametrised over array variables+-- represented with de Bruijn indices.+--+-- * Scalar functions and expressions embedded in well-formed array+--   computations cannot contain free scalar variable indices. The latter+--   cannot be bound in array computations, and hence, cannot appear in any+--   well-formed program.+--+-- * The let-form is used to represent the sharing discovered by common+--   subexpression elimination as well as to control evaluation order. (We+--   need to hoist array expressions out of scalar expressions---they occur+--   in scalar indexing and in determining an arrays shape.)+--+-- The data type is parameterised over the surface types (not the+-- representation type).+--+-- We use a non-recursive variant parametrised over the recursive closure,+-- to facilitate attribute calculation in the backend.+--+data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where++  -- Local non-recursive binding to represent sharing and demand+  -- explicitly. Note this is an eager binding!+  --+  Alet        :: ALeftHandSide bndArrs aenv aenv'+              -> acc            aenv  bndArrs         -- bound expression+              -> acc            aenv' bodyArrs        -- the bound expression scope+              -> PreOpenAcc acc aenv  bodyArrs++  -- Variable bound by a 'Let', represented by a de Bruijn index+  --+  Avar        :: ArrayVar       aenv (Array sh e)+              -> PreOpenAcc acc aenv (Array sh e)++  -- Tuples of arrays+  --+  Apair       :: acc            aenv as+              -> acc            aenv bs+              -> PreOpenAcc acc aenv (as, bs)++  Anil        :: PreOpenAcc acc aenv ()++  -- Array-function application.+  --+  -- The array function is not closed at the core level because we need access+  -- to free variables introduced by 'run1' style evaluators. See Issue#95.+  --+  Apply       :: ArraysR arrs2+              -> PreOpenAfun acc aenv (arrs1 -> arrs2)+              -> acc             aenv arrs1+              -> PreOpenAcc  acc aenv arrs2++  -- Apply a backend-specific foreign function to an array, with a pure+  -- Accelerate version for use with other backends. The functions must be+  -- closed.+  --+  Aforeign    :: Foreign asm+              => ArraysR bs+              -> asm                   (as -> bs) -- The foreign function for a given backend+              -> PreAfun      acc      (as -> bs) -- Fallback implementation(s)+              -> acc              aenv as         -- Arguments to the function+              -> PreOpenAcc   acc aenv bs++  -- If-then-else for array-level computations+  --+  Acond       :: Exp            aenv PrimBool+              -> acc            aenv arrs+              -> acc            aenv arrs+              -> PreOpenAcc acc aenv arrs++  -- Value-recursion for array-level computations+  --+  Awhile      :: PreOpenAfun acc aenv (arrs -> Scalar PrimBool) -- continue iteration while true+              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate+              -> acc             aenv arrs                      -- initial value+              -> PreOpenAcc  acc aenv arrs+++  -- Array inlet. Triggers (possibly) asynchronous host->device transfer if+  -- necessary.+  --+  Use         :: ArrayR (Array sh e)+              -> Array sh e+              -> PreOpenAcc acc aenv (Array sh e)++  -- Capture a scalar (or a tuple of scalars) in a singleton array+  --+  Unit        :: TypeR e+              -> Exp            aenv e+              -> PreOpenAcc acc aenv (Scalar e)++  -- Change the shape of an array without altering its contents.+  -- Precondition (this may not be checked!):+  --+  -- > dim == size dim'+  --+  Reshape     :: ShapeR sh+              -> Exp            aenv sh                         -- new shape+              -> acc            aenv (Array sh' e)              -- array to be reshaped+              -> PreOpenAcc acc aenv (Array sh e)++  -- Construct a new array by applying a function to each index.+  --+  Generate    :: ArrayR (Array sh e)+              -> Exp            aenv sh                         -- output shape+              -> Fun            aenv (sh -> e)                  -- representation function+              -> PreOpenAcc acc aenv (Array sh e)++  -- Hybrid map/backpermute, where we separate the index and value+  -- transformations.+  --+  Transform   :: ArrayR (Array sh' b)+              -> Exp            aenv sh'                        -- dimension of the result+              -> Fun            aenv (sh' -> sh)                -- index permutation function+              -> Fun            aenv (a   -> b)                 -- function to apply at each element+              ->            acc aenv (Array sh  a)              -- source array+              -> PreOpenAcc acc aenv (Array sh' b)++  -- Replicate an array across one or more dimensions as given by the first+  -- argument+  --+  Replicate   :: SliceIndex slix sl co sh                       -- slice type specification+              -> Exp            aenv slix                       -- slice value specification+              -> acc            aenv (Array sl e)               -- data to be replicated+              -> PreOpenAcc acc aenv (Array sh e)++  -- Index a sub-array out of an array; i.e., the dimensions not indexed+  -- are returned whole+  --+  Slice       :: SliceIndex slix sl co sh                       -- slice type specification+              -> acc            aenv (Array sh e)               -- array to be indexed+              -> Exp            aenv slix                       -- slice value specification+              -> PreOpenAcc acc aenv (Array sl e)++  -- Apply the given unary function to all elements of the given array+  --+  Map         :: TypeR e'+              -> Fun            aenv (e -> e')+              -> acc            aenv (Array sh e)+              -> PreOpenAcc acc aenv (Array sh e')++  -- Apply a given binary function pairwise to all elements of the given+  -- arrays. The length of the result is the length of the shorter of the+  -- two argument arrays.+  --+  ZipWith     :: TypeR e3+              -> Fun            aenv (e1 -> e2 -> e3)+              -> acc            aenv (Array sh e1)+              -> acc            aenv (Array sh e2)+              -> PreOpenAcc acc aenv (Array sh e3)++  -- Fold along the innermost dimension of an array with a given+  -- /associative/ function.+  --+  Fold        :: Fun            aenv (e -> e -> e)              -- combination function+              -> Maybe     (Exp aenv e)                         -- default value+              -> acc            aenv (Array (sh, Int) e)        -- folded array+              -> PreOpenAcc acc aenv (Array sh e)++  -- Segmented fold along the innermost dimension of an array with a given+  -- /associative/ function+  --+  FoldSeg     :: IntegralType i+              -> Fun            aenv (e -> e -> e)              -- combination function+              -> Maybe     (Exp aenv e)                         -- default value+              -> acc            aenv (Array (sh, Int) e)        -- folded array+              -> acc            aenv (Segments i)               -- segment descriptor+              -> PreOpenAcc acc aenv (Array (sh, Int) e)++  -- Haskell-style scan of a linear array with a given+  -- /associative/ function and optionally an initial element+  -- (which does not need to be the neutral of the associative operations)+  -- If no initial value is given, this is a scan1+  --+  Scan        :: Direction+              -> Fun            aenv (e -> e -> e)              -- combination function+              -> Maybe     (Exp aenv e)                         -- initial value+              -> acc            aenv (Array (sh, Int) e)+              -> PreOpenAcc acc aenv (Array (sh, Int) e)++  -- Like 'Scan', but produces a rightmost (in case of a left-to-right scan)+  -- fold value and an array with the same length as the input array (the+  -- fold value would be the rightmost element in a Haskell-style scan)+  --+  Scan'       :: Direction+              -> Fun            aenv (e -> e -> e)              -- combination function+              -> Exp            aenv e                          -- initial value+              -> acc            aenv (Array (sh, Int) e)+              -> PreOpenAcc acc aenv (Array (sh, Int) e, Array sh e)++  -- Generalised forward permutation is characterised by a permutation function+  -- that determines for each element of the source array where it should go in+  -- the output. The permutation can be between arrays of varying shape and+  -- dimensionality.+  --+  -- Other characteristics of the permutation function 'f':+  --+  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'+  --      (i.e. a tuple of -1 values) then those elements of the domain are+  --      dropped.+  --+  --   2. 'f' is not surjective: positions in the target array need not be+  --      picked up by the permutation function, so the target array must first+  --      be initialised from an array of default values.+  --+  --   3. 'f' is not injective: distinct elements of the domain may map to the+  --      same position in the target array. In this case the combination+  --      function is used to combine elements, which needs to be /associative/+  --      and /commutative/.+  --+  Permute     :: Fun            aenv (e -> e -> e)              -- combination function+              -> acc            aenv (Array sh' e)              -- default values+              -> Fun            aenv (sh -> PrimMaybe sh')      -- permutation function+              -> acc            aenv (Array sh e)               -- source array+              -> PreOpenAcc acc aenv (Array sh' e)++  -- Generalised multi-dimensional backwards permutation; the permutation can+  -- be between arrays of varying shape; the permutation function must be total+  --+  Backpermute :: ShapeR sh'+              -> Exp            aenv sh'                        -- dimensions of the result+              -> Fun            aenv (sh' -> sh)                -- permutation function+              -> acc            aenv (Array sh e)               -- source array+              -> PreOpenAcc acc aenv (Array sh' e)++  -- Map a stencil over an array.  In contrast to 'map', the domain of+  -- a stencil function is an entire /neighbourhood/ of each array element.+  --+  Stencil     :: StencilR sh e stencil+              -> TypeR e'+              -> Fun             aenv (stencil -> e')           -- stencil function+              -> Boundary        aenv (Array sh e)              -- boundary condition+              -> acc             aenv (Array sh e)              -- source array+              -> PreOpenAcc  acc aenv (Array sh e')++  -- Map a binary stencil over an array.+  --+  Stencil2    :: StencilR sh a stencil1+              -> StencilR sh b stencil2+              -> TypeR c+              -> Fun             aenv (stencil1 -> stencil2 -> c) -- stencil function+              -> Boundary        aenv (Array sh a)                -- boundary condition #1+              -> acc             aenv (Array sh a)                -- source array #1+              -> Boundary        aenv (Array sh b)                -- boundary condition #2+              -> acc             aenv (Array sh b)                -- source array #2+              -> PreOpenAcc acc  aenv (Array sh c)+++data Direction = LeftToRight | RightToLeft+  deriving Eq+++-- | Vanilla boundary condition specification for stencil operations+--+data Boundary aenv t where+  -- Clamp coordinates to the extent of the array+  Clamp     :: Boundary aenv t++  -- Mirror coordinates beyond the array extent+  Mirror    :: Boundary aenv t++  -- Wrap coordinates around on each dimension+  Wrap      :: Boundary aenv t++  -- Use a constant value for outlying coordinates+  Constant  :: e+            -> Boundary aenv (Array sh e)++  -- Apply the given function to outlying coordinates+  Function  :: Fun aenv (sh -> e)+            -> Boundary aenv (Array sh e)+++-- Embedded expressions+-- --------------------++-- | Vanilla open function abstraction+--+data OpenFun env aenv t where+  Body ::                             OpenExp env  aenv t -> OpenFun env aenv t+  Lam  :: ELeftHandSide a env env' -> OpenFun env' aenv t -> OpenFun env aenv (a -> t)++-- | Vanilla function without free scalar variables+--+type Fun = OpenFun ()++-- | Vanilla expression without free scalar variables+--+type Exp = OpenExp ()++-- Types for scalar bindings+--+type ELeftHandSide = LeftHandSide ScalarType+type ExpVar        = Var ScalarType+type ExpVars env   = Vars ScalarType env++expVars :: ExpVars env t -> OpenExp env aenv t+expVars TupRunit         = Nil+expVars (TupRsingle var) = Evar var+expVars (TupRpair v1 v2) = expVars v1 `Pair` expVars v2+++-- | Vanilla open expressions using de Bruijn indices for variables ranging+-- over tuples of scalars and arrays of tuples. All code, except Cond, is+-- evaluated eagerly. N-tuples are represented as nested pairs.+--+-- The data type is parametrised over the representation type (not the+-- surface types).+--+data OpenExp env aenv t where++  -- Local binding of a scalar expression+  Let           :: ELeftHandSide bnd_t env env'+                -> OpenExp env  aenv bnd_t+                -> OpenExp env' aenv body_t+                -> OpenExp env  aenv body_t++  -- Variable index, ranging only over tuples or scalars+  Evar          :: ExpVar env t+                -> OpenExp env aenv t++  -- Apply a backend-specific foreign function+  Foreign       :: Foreign asm+                => TypeR y+                -> asm    (x -> y)    -- foreign function+                -> Fun () (x -> y)    -- alternate implementation (for other backends)+                -> OpenExp env aenv x+                -> OpenExp env aenv y++  -- Tuples+  Pair          :: OpenExp env aenv t1+                -> OpenExp env aenv t2+                -> OpenExp env aenv (t1, t2)++  Nil           :: OpenExp env aenv ()++  -- SIMD vectors+  VecPack       :: KnownNat n+                => VecR n s tup+                -> OpenExp env aenv tup+                -> OpenExp env aenv (Vec n s)++  VecUnpack     :: KnownNat n+                => VecR n s tup+                -> OpenExp env aenv (Vec n s)+                -> OpenExp env aenv tup++  -- Array indices & shapes+  IndexSlice    :: SliceIndex slix sl co sh+                -> OpenExp env aenv slix+                -> OpenExp env aenv sh+                -> OpenExp env aenv sl++  IndexFull     :: SliceIndex slix sl co sh+                -> OpenExp env aenv slix+                -> OpenExp env aenv sl+                -> OpenExp env aenv sh++  -- Shape and index conversion+  ToIndex       :: ShapeR sh+                -> OpenExp env aenv sh           -- shape of the array+                -> OpenExp env aenv sh           -- index into the array+                -> OpenExp env aenv Int++  FromIndex     :: ShapeR sh+                -> OpenExp env aenv sh           -- shape of the array+                -> OpenExp env aenv Int          -- index into linear representation+                -> OpenExp env aenv sh++  -- Case statement+  Case          :: OpenExp env aenv TAG+                -> [(TAG, OpenExp env aenv b)]      -- list of equations+                -> Maybe (OpenExp env aenv b)       -- default case+                -> OpenExp env aenv b++  -- Conditional expression (non-strict in 2nd and 3rd argument)+  Cond          :: OpenExp env aenv PrimBool+                -> OpenExp env aenv t+                -> OpenExp env aenv t+                -> OpenExp env aenv t++  -- Value recursion+  While         :: OpenFun env aenv (a -> PrimBool) -- continue while true+                -> OpenFun env aenv (a -> a)        -- function to iterate+                -> OpenExp env aenv a               -- initial value+                -> OpenExp env aenv a++  -- Constant values+  Const         :: ScalarType t+                -> t+                -> OpenExp env aenv t++  PrimConst     :: PrimConst t+                -> OpenExp env aenv t++  -- Primitive scalar operations+  PrimApp       :: PrimFun (a -> r)+                -> OpenExp env aenv a+                -> OpenExp env aenv r++  -- Project a single scalar from an array.+  -- The array expression can not contain any free scalar variables.+  Index         :: ArrayVar    aenv (Array dim t)+                -> OpenExp env aenv dim+                -> OpenExp env aenv t++  LinearIndex   :: ArrayVar    aenv (Array dim t)+                -> OpenExp env aenv Int+                -> OpenExp env aenv t++  -- Array shape.+  -- The array expression can not contain any free scalar variables.+  Shape         :: ArrayVar    aenv (Array dim e)+                -> OpenExp env aenv dim++  -- Number of elements of an array given its shape+  ShapeSize     :: ShapeR dim+                -> OpenExp env aenv dim+                -> OpenExp env aenv Int++  -- Unsafe operations (may fail or result in undefined behaviour)+  -- An unspecified bit pattern+  Undef         :: ScalarType t+                -> OpenExp env aenv t++  -- Reinterpret the bits of a value as a different type+  Coerce        :: BitSizeEq a b+                => ScalarType a+                -> ScalarType b+                -> OpenExp env aenv a+                -> OpenExp env aenv b++-- |Primitive constant values+--+data PrimConst ty where++  -- constants from Bounded+  PrimMinBound  :: BoundedType a -> PrimConst a+  PrimMaxBound  :: BoundedType a -> PrimConst a++  -- constant from Floating+  PrimPi        :: FloatingType a -> PrimConst a+++-- |Primitive scalar operations+--+data PrimFun sig where++  -- operators from Num+  PrimAdd  :: NumType a -> PrimFun ((a, a) -> a)+  PrimSub  :: NumType a -> PrimFun ((a, a) -> a)+  PrimMul  :: NumType a -> PrimFun ((a, a) -> a)+  PrimNeg  :: NumType a -> PrimFun (a      -> a)+  PrimAbs  :: NumType a -> PrimFun (a      -> a)+  PrimSig  :: NumType a -> PrimFun (a      -> a)++  -- operators from Integral+  PrimQuot     :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimRem      :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimQuotRem  :: IntegralType a -> PrimFun ((a, a)   -> (a, a))+  PrimIDiv     :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimMod      :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimDivMod   :: IntegralType a -> PrimFun ((a, a)   -> (a, a))++  -- operators from Bits & FiniteBits+  PrimBAnd               :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBOr                :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBXor               :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBNot               :: IntegralType a -> PrimFun (a        -> a)+  PrimBShiftL            :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBShiftR            :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBRotateL           :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBRotateR           :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimPopCount           :: IntegralType a -> PrimFun (a -> Int)+  PrimCountLeadingZeros  :: IntegralType a -> PrimFun (a -> Int)+  PrimCountTrailingZeros :: IntegralType a -> PrimFun (a -> Int)++  -- operators from Fractional and Floating+  PrimFDiv        :: FloatingType a -> PrimFun ((a, a) -> a)+  PrimRecip       :: FloatingType a -> PrimFun (a      -> a)+  PrimSin         :: FloatingType a -> PrimFun (a      -> a)+  PrimCos         :: FloatingType a -> PrimFun (a      -> a)+  PrimTan         :: FloatingType a -> PrimFun (a      -> a)+  PrimAsin        :: FloatingType a -> PrimFun (a      -> a)+  PrimAcos        :: FloatingType a -> PrimFun (a      -> a)+  PrimAtan        :: FloatingType a -> PrimFun (a      -> a)+  PrimSinh        :: FloatingType a -> PrimFun (a      -> a)+  PrimCosh        :: FloatingType a -> PrimFun (a      -> a)+  PrimTanh        :: FloatingType a -> PrimFun (a      -> a)+  PrimAsinh       :: FloatingType a -> PrimFun (a      -> a)+  PrimAcosh       :: FloatingType a -> PrimFun (a      -> a)+  PrimAtanh       :: FloatingType a -> PrimFun (a      -> a)+  PrimExpFloating :: FloatingType a -> PrimFun (a      -> a)+  PrimSqrt        :: FloatingType a -> PrimFun (a      -> a)+  PrimLog         :: FloatingType a -> PrimFun (a      -> a)+  PrimFPow        :: FloatingType a -> PrimFun ((a, a) -> a)+  PrimLogBase     :: FloatingType a -> PrimFun ((a, a) -> a)++  -- FIXME: add missing operations from RealFrac & RealFloat++  -- operators from RealFrac+  PrimTruncate :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimRound    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimFloor    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimCeiling  :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  -- PrimProperFraction :: FloatingType a -> IntegralType b -> PrimFun (a -> (b, a))++  -- operators from RealFloat+  PrimAtan2      :: FloatingType a -> PrimFun ((a, a) -> a)+  PrimIsNaN      :: FloatingType a -> PrimFun (a -> PrimBool)+  PrimIsInfinite :: FloatingType a -> PrimFun (a -> PrimBool)++  -- relational and equality operators+  PrimLt   :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimGt   :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimLtEq :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimGtEq :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimEq   :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimNEq  :: SingleType a -> PrimFun ((a, a) -> PrimBool)+  PrimMax  :: SingleType a -> PrimFun ((a, a) -> a)+  PrimMin  :: SingleType a -> PrimFun ((a, a) -> a)++  -- logical operators+  --+  -- Note that these operators are strict in both arguments. That is, the+  -- second argument of PrimLAnd is always evaluated even when the first+  -- argument is false.+  --+  -- We define (surface level) (&&) and (||) using if-then-else to enable+  -- short-circuiting, while (&&!) and (||!) are strict versions of these+  -- operators, which are defined using PrimLAnd and PrimLOr.+  --+  PrimLAnd :: PrimFun ((PrimBool, PrimBool) -> PrimBool)+  PrimLOr  :: PrimFun ((PrimBool, PrimBool) -> PrimBool)+  PrimLNot :: PrimFun (PrimBool             -> PrimBool)++  -- general conversion between types+  PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b)+  PrimToFloating   :: NumType a -> FloatingType b -> PrimFun (a -> b)+++-- Type utilities+-- --------------++class HasArraysR f where+  arraysR :: f aenv a -> ArraysR a++instance HasArraysR OpenAcc where+  arraysR (OpenAcc a) = arraysR a++arrayR :: HasArraysR f => f aenv (Array sh e) -> ArrayR (Array sh e)+arrayR a = case arraysR a of+  TupRsingle aR -> aR++instance HasArraysR acc => HasArraysR (PreOpenAcc acc) where+  arraysR (Alet _ _ body)             = arraysR body+  arraysR (Avar (Var aR _))           = TupRsingle aR+  arraysR (Apair as bs)               = TupRpair (arraysR as) (arraysR bs)+  arraysR Anil                        = TupRunit+  arraysR (Apply aR _ _)              = aR+  arraysR (Aforeign r _ _ _)          = r+  arraysR (Acond _ a _)               = arraysR a+  arraysR (Awhile _ (Alam lhs _) _)   = lhsToTupR lhs+  arraysR Awhile{}                    = error "I want my, I want my MTV!"+  arraysR (Use aR _)                  = TupRsingle aR+  arraysR (Unit tR _)                 = arraysRarray ShapeRz tR+  arraysR (Reshape sh _ a)            = let ArrayR _ tR = arrayR a+                                         in arraysRarray sh tR+  arraysR (Generate aR _ _)           = TupRsingle aR+  arraysR (Transform aR _ _ _ _)      = TupRsingle aR+  arraysR (Replicate slice _ a)       = let ArrayR _ tR = arrayR a+                                         in arraysRarray (sliceDomainR slice) tR+  arraysR (Slice slice a _)           = let ArrayR _ tR = arrayR a+                                         in arraysRarray (sliceShapeR slice) tR+  arraysR (Map tR _ a)                = let ArrayR sh _ = arrayR a+                                         in arraysRarray sh tR+  arraysR (ZipWith tR _ a _)          = let ArrayR sh _ = arrayR a+                                         in arraysRarray sh tR+  arraysR (Fold _ _ a)                = let ArrayR (ShapeRsnoc sh) tR = arrayR a+                                         in arraysRarray sh tR+  arraysR (FoldSeg _ _ _ a _)         = arraysR a+  arraysR (Scan _ _ _ a)              = arraysR a+  arraysR (Scan' _ _ _ a)             = let aR@(ArrayR (ShapeRsnoc sh) tR) = arrayR a+                                         in TupRsingle aR `TupRpair` TupRsingle (ArrayR sh tR)+  arraysR (Permute _ a _ _)           = arraysR a+  arraysR (Backpermute sh _ _ a)      = let ArrayR _ tR = arrayR a+                                         in arraysRarray sh tR+  arraysR (Stencil _ tR _ _ a)        = let ArrayR sh _ = arrayR a+                                         in arraysRarray sh tR+  arraysR (Stencil2 _ _ tR _ _ a _ _) = let ArrayR sh _ = arrayR a+                                         in arraysRarray sh tR++expType :: HasCallStack => OpenExp aenv env t -> TypeR t+expType = \case+  Let _ _ body                 -> expType body+  Evar (Var tR _)              -> TupRsingle tR+  Foreign tR _ _ _             -> tR+  Pair e1 e2                   -> TupRpair (expType e1) (expType e2)+  Nil                          -> TupRunit+  VecPack   vecR _             -> TupRsingle $ VectorScalarType $ vecRvector vecR+  VecUnpack vecR _             -> vecRtuple vecR+  IndexSlice si _ _            -> shapeType $ sliceShapeR si+  IndexFull  si _ _            -> shapeType $ sliceDomainR si+  ToIndex{}                    -> TupRsingle scalarTypeInt+  FromIndex shr _ _            -> shapeType shr+  Case _ ((_,e):_) _           -> expType e+  Case _ [] (Just e)           -> expType e+  Case{}                       -> internalError "empty case encountered"+  Cond _ e _                   -> expType e+  While _ (Lam lhs _) _        -> lhsToTupR lhs+  While{}                      -> error "What's the matter, you're running in the shadows"+  Const tR _                   -> TupRsingle tR+  PrimConst c                  -> TupRsingle $ SingleScalarType $ primConstType c+  PrimApp f _                  -> snd $ primFunType f+  Index (Var repr _) _         -> arrayRtype repr+  LinearIndex (Var repr _) _   -> arrayRtype repr+  Shape (Var repr _)           -> shapeType $ arrayRshape repr+  ShapeSize{}                  -> TupRsingle scalarTypeInt+  Undef tR                     -> TupRsingle tR+  Coerce _ tR _                -> TupRsingle tR++primConstType :: PrimConst a -> SingleType a+primConstType = \case+  PrimMinBound t -> bounded t+  PrimMaxBound t -> bounded t+  PrimPi       t -> floating t+  where+    bounded :: BoundedType a -> SingleType a+    bounded (IntegralBoundedType t) = NumSingleType $ IntegralNumType t++    floating :: FloatingType t -> SingleType t+    floating = NumSingleType . FloatingNumType++primFunType :: PrimFun (a -> b) -> (TypeR a, TypeR b)+primFunType = \case+  -- Num+  PrimAdd t                 -> binary' $ num t+  PrimSub t                 -> binary' $ num t+  PrimMul t                 -> binary' $ num t+  PrimNeg t                 -> unary'  $ num t+  PrimAbs t                 -> unary'  $ num t+  PrimSig t                 -> unary'  $ num t++  -- Integral+  PrimQuot t                -> binary' $ integral t+  PrimRem  t                -> binary' $ integral t+  PrimQuotRem t             -> unary' $ integral t `TupRpair` integral t+  PrimIDiv t                -> binary' $ integral t+  PrimMod  t                -> binary' $ integral t+  PrimDivMod t              -> unary' $ integral t `TupRpair` integral t++  -- Bits & FiniteBits+  PrimBAnd t                -> binary' $ integral t+  PrimBOr t                 -> binary' $ integral t+  PrimBXor t                -> binary' $ integral t+  PrimBNot t                -> unary' $ integral t+  PrimBShiftL t             -> (integral t `TupRpair` int, integral t)+  PrimBShiftR t             -> (integral t `TupRpair` int, integral t)+  PrimBRotateL t            -> (integral t `TupRpair` int, integral t)+  PrimBRotateR t            -> (integral t `TupRpair` int, integral t)+  PrimPopCount t            -> unary (integral t) int+  PrimCountLeadingZeros t   -> unary (integral t) int+  PrimCountTrailingZeros t  -> unary (integral t) int++  -- Fractional, Floating+  PrimFDiv t                -> binary' $ floating t+  PrimRecip t               -> unary'  $ floating t+  PrimSin t                 -> unary'  $ floating t+  PrimCos t                 -> unary'  $ floating t+  PrimTan t                 -> unary'  $ floating t+  PrimAsin t                -> unary'  $ floating t+  PrimAcos t                -> unary'  $ floating t+  PrimAtan t                -> unary'  $ floating t+  PrimSinh t                -> unary'  $ floating t+  PrimCosh t                -> unary'  $ floating t+  PrimTanh t                -> unary'  $ floating t+  PrimAsinh t               -> unary'  $ floating t+  PrimAcosh t               -> unary'  $ floating t+  PrimAtanh t               -> unary'  $ floating t+  PrimExpFloating t         -> unary'  $ floating t+  PrimSqrt t                -> unary'  $ floating t+  PrimLog t                 -> unary'  $ floating t+  PrimFPow t                -> binary' $ floating t+  PrimLogBase t             -> binary' $ floating t++  -- RealFrac+  PrimTruncate a b          -> unary (floating a) (integral b)+  PrimRound a b             -> unary (floating a) (integral b)+  PrimFloor a b             -> unary (floating a) (integral b)+  PrimCeiling a b           -> unary (floating a) (integral b)++  -- RealFloat+  PrimAtan2 t               -> binary' $ floating t+  PrimIsNaN t               -> unary (floating t) bool+  PrimIsInfinite t          -> unary (floating t) bool++  -- Relational and equality+  PrimLt t                  -> compare' t+  PrimGt t                  -> compare' t+  PrimLtEq t                -> compare' t+  PrimGtEq t                -> compare' t+  PrimEq t                  -> compare' t+  PrimNEq t                 -> compare' t+  PrimMax t                 -> binary' $ single t+  PrimMin t                 -> binary' $ single t++  -- Logical+  PrimLAnd                  -> binary' bool+  PrimLOr                   -> binary' bool+  PrimLNot                  -> unary' bool++  -- general conversion between types+  PrimFromIntegral a b      -> unary (integral a) (num b)+  PrimToFloating   a b      -> unary (num a) (floating b)++  where+    unary a b  = (a, b)+    unary' a   = unary a a+    binary a b = (a `TupRpair` a, b)+    binary' a  = binary a a+    compare' a = binary (single a) bool++    single   = TupRsingle . SingleScalarType+    num      = TupRsingle . SingleScalarType . NumSingleType+    integral = num . IntegralNumType+    floating = num . FloatingNumType++    bool     = TupRsingle scalarTypeWord8+    int      = TupRsingle scalarTypeInt+++-- Normal form data+-- ================++instance NFData (OpenAfun aenv f) where+  rnf = rnfOpenAfun++instance NFData (OpenAcc aenv t) where+  rnf = rnfOpenAcc++instance NFData (OpenExp env aenv t) where+  rnf = rnfOpenExp++instance NFData (OpenFun env aenv t) where+  rnf = rnfOpenFun+++type NFDataAcc acc = forall aenv t. acc aenv t -> ()++rnfOpenAfun :: OpenAfun aenv t -> ()+rnfOpenAfun = rnfPreOpenAfun rnfOpenAcc++rnfPreOpenAfun :: NFDataAcc acc -> PreOpenAfun acc aenv t -> ()+rnfPreOpenAfun rnfA (Abody b) = rnfA b+rnfPreOpenAfun rnfA (Alam lhs f) = rnfALeftHandSide lhs `seq` rnfPreOpenAfun rnfA f++rnfOpenAcc :: OpenAcc aenv t -> ()+rnfOpenAcc (OpenAcc pacc) = rnfPreOpenAcc rnfOpenAcc pacc++rnfPreOpenAcc :: forall acc aenv t. HasArraysR acc => NFDataAcc acc -> PreOpenAcc acc aenv t -> ()+rnfPreOpenAcc rnfA pacc =+  let+      rnfAF :: PreOpenAfun acc aenv' t' -> ()+      rnfAF = rnfPreOpenAfun rnfA++      rnfE :: OpenExp env' aenv' t' -> ()+      rnfE = rnfOpenExp++      rnfF :: OpenFun env' aenv' t' -> ()+      rnfF = rnfOpenFun++      rnfB :: ArrayR (Array sh e) -> Boundary aenv' (Array sh e) -> ()+      rnfB = rnfBoundary+  in+  case pacc of+    Alet lhs bnd body         -> rnfALeftHandSide lhs `seq` rnfA bnd `seq` rnfA body+    Avar var                  -> rnfArrayVar var+    Apair as bs               -> rnfA as `seq` rnfA bs+    Anil                      -> ()+    Apply repr afun acc       -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc+    Aforeign repr asm afun a  -> rnfTupR rnfArrayR repr `seq` rnf (strForeign asm) `seq` rnfAF afun `seq` rnfA a+    Acond p a1 a2             -> rnfE p `seq` rnfA a1 `seq` rnfA a2+    Awhile p f a              -> rnfAF p `seq` rnfAF f `seq` rnfA a+    Use repr arr              -> rnfArray repr arr+    Unit tp x                 -> rnfTypeR tp `seq` rnfE x+    Reshape shr sh a          -> rnfShapeR shr `seq` rnfE sh `seq` rnfA a+    Generate repr sh f        -> rnfArrayR repr `seq` rnfE sh `seq` rnfF f+    Transform repr sh p f a   -> rnfArrayR repr `seq` rnfE sh `seq` rnfF p `seq` rnfF f `seq` rnfA a+    Replicate slice sh a      -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a+    Slice slice a sh          -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a+    Map tp f a                -> rnfTypeR tp `seq` rnfF f `seq` rnfA a+    ZipWith tp f a1 a2        -> rnfTypeR tp `seq` rnfF f `seq` rnfA a1 `seq` rnfA a2+    Fold f z a                -> rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a+    FoldSeg i f z a s         -> rnfIntegralType i `seq` rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a `seq` rnfA s+    Scan d f z a              -> d `seq` rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a+    Scan' d f z a             -> d `seq` rnfF f `seq` rnfE z `seq` rnfA a+    Permute f d p a           -> rnfF f `seq` rnfA d `seq` rnfF p `seq` rnfA a+    Backpermute shr sh f a    -> rnfShapeR shr `seq` rnfE sh `seq` rnfF f `seq` rnfA a+    Stencil sr tp f b a       ->+      let+        TupRsingle (ArrayR shr _) = arraysR a+        repr                      = ArrayR shr $ stencilEltR sr+      in rnfStencilR sr `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr b  `seq` rnfA a+    Stencil2 sr1 sr2 tp f b1 a1 b2 a2 ->+      let+        TupRsingle (ArrayR shr _) = arraysR a1+        repr1 = ArrayR shr $ stencilEltR sr1+        repr2 = ArrayR shr $ stencilEltR sr2+      in rnfStencilR sr1 `seq` rnfStencilR sr2 `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr1 b1 `seq` rnfB repr2 b2 `seq` rnfA a1 `seq` rnfA a2++rnfArrayVar :: ArrayVar aenv a -> ()+rnfArrayVar = rnfVar rnfArrayR++rnfALeftHandSide :: ALeftHandSide arrs aenv aenv' -> ()+rnfALeftHandSide = rnfLeftHandSide rnfArrayR++rnfBoundary :: forall aenv sh e. ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> ()+rnfBoundary _             Clamp        = ()+rnfBoundary _             Mirror       = ()+rnfBoundary _             Wrap         = ()+rnfBoundary (ArrayR _ tR) (Constant c) = rnfConst tR c+rnfBoundary _             (Function f) = rnfOpenFun f++rnfMaybe :: (a -> ()) -> Maybe a -> ()+rnfMaybe _ Nothing  = ()+rnfMaybe f (Just x) = f x++rnfList :: (a -> ()) -> [a] -> ()+rnfList r = go+  where+    go []     = ()+    go (x:xs) = r x `seq` go xs++rnfOpenFun :: OpenFun env aenv t -> ()+rnfOpenFun (Body b)    = rnfOpenExp b+rnfOpenFun (Lam lhs f) = rnfELeftHandSide lhs `seq` rnfOpenFun f++rnfOpenExp :: forall env aenv t. OpenExp env aenv t -> ()+rnfOpenExp topExp =+  let+      rnfF :: OpenFun env' aenv' t' -> ()+      rnfF = rnfOpenFun++      rnfE :: OpenExp env' aenv' t' -> ()+      rnfE = rnfOpenExp+  in+  case topExp of+    Let lhs bnd body          -> rnfELeftHandSide lhs `seq` rnfE bnd `seq` rnfE body+    Evar v                    -> rnfExpVar v+    Foreign tp asm f x        -> rnfTypeR tp `seq` rnf (strForeign asm) `seq` rnfF f `seq` rnfE x+    Const tp c                -> c `seq` rnfScalarType tp -- scalars should have (nf == whnf)+    Undef tp                  -> rnfScalarType tp+    Pair a b                  -> rnfE a `seq` rnfE b+    Nil                       -> ()+    VecPack   vecr e          -> rnfVecR vecr `seq` rnfE e+    VecUnpack vecr e          -> rnfVecR vecr `seq` rnfE e+    IndexSlice slice slix sh  -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sh+    IndexFull slice slix sl   -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sl+    ToIndex shr sh ix         -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix+    FromIndex shr sh ix       -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix+    Case e rhs def            -> rnfE e `seq` rnfList (\(t,c) -> t `seq` rnfE c) rhs `seq` rnfMaybe rnfE def+    Cond p e1 e2              -> rnfE p `seq` rnfE e1 `seq` rnfE e2+    While p f x               -> rnfF p `seq` rnfF f `seq` rnfE x+    PrimConst c               -> rnfPrimConst c+    PrimApp f x               -> rnfPrimFun f `seq` rnfE x+    Index a ix                -> rnfArrayVar a `seq` rnfE ix+    LinearIndex a ix          -> rnfArrayVar a `seq` rnfE ix+    Shape a                   -> rnfArrayVar a+    ShapeSize shr sh          -> rnfShapeR shr `seq` rnfE sh+    Coerce t1 t2 e            -> rnfScalarType t1 `seq` rnfScalarType t2 `seq` rnfE e++rnfExpVar :: ExpVar env t -> ()+rnfExpVar = rnfVar rnfScalarType++rnfELeftHandSide :: ELeftHandSide t env env' -> ()+rnfELeftHandSide= rnfLeftHandSide rnfScalarType++rnfConst :: TypeR t -> t -> ()+rnfConst TupRunit          ()    = ()+rnfConst (TupRsingle t)    !_    = rnfScalarType t  -- scalars should have (nf == whnf)+rnfConst (TupRpair ta tb)  (a,b) = rnfConst ta a `seq` rnfConst tb b++rnfPrimConst :: PrimConst c -> ()+rnfPrimConst (PrimMinBound t) = rnfBoundedType t+rnfPrimConst (PrimMaxBound t) = rnfBoundedType t+rnfPrimConst (PrimPi t)       = rnfFloatingType t++rnfPrimFun :: PrimFun f -> ()+rnfPrimFun (PrimAdd t)                = rnfNumType t+rnfPrimFun (PrimSub t)                = rnfNumType t+rnfPrimFun (PrimMul t)                = rnfNumType t+rnfPrimFun (PrimNeg t)                = rnfNumType t+rnfPrimFun (PrimAbs t)                = rnfNumType t+rnfPrimFun (PrimSig t)                = rnfNumType t+rnfPrimFun (PrimQuot t)               = rnfIntegralType t+rnfPrimFun (PrimRem t)                = rnfIntegralType t+rnfPrimFun (PrimQuotRem t)            = rnfIntegralType t+rnfPrimFun (PrimIDiv t)               = rnfIntegralType t+rnfPrimFun (PrimMod t)                = rnfIntegralType t+rnfPrimFun (PrimDivMod t)             = rnfIntegralType t+rnfPrimFun (PrimBAnd t)               = rnfIntegralType t+rnfPrimFun (PrimBOr t)                = rnfIntegralType t+rnfPrimFun (PrimBXor t)               = rnfIntegralType t+rnfPrimFun (PrimBNot t)               = rnfIntegralType t+rnfPrimFun (PrimBShiftL t)            = rnfIntegralType t+rnfPrimFun (PrimBShiftR t)            = rnfIntegralType t+rnfPrimFun (PrimBRotateL t)           = rnfIntegralType t+rnfPrimFun (PrimBRotateR t)           = rnfIntegralType t+rnfPrimFun (PrimPopCount t)           = rnfIntegralType t+rnfPrimFun (PrimCountLeadingZeros t)  = rnfIntegralType t+rnfPrimFun (PrimCountTrailingZeros t) = rnfIntegralType t+rnfPrimFun (PrimFDiv t)               = rnfFloatingType t+rnfPrimFun (PrimRecip t)              = rnfFloatingType t+rnfPrimFun (PrimSin t)                = rnfFloatingType t+rnfPrimFun (PrimCos t)                = rnfFloatingType t+rnfPrimFun (PrimTan t)                = rnfFloatingType t+rnfPrimFun (PrimAsin t)               = rnfFloatingType t+rnfPrimFun (PrimAcos t)               = rnfFloatingType t+rnfPrimFun (PrimAtan t)               = rnfFloatingType t+rnfPrimFun (PrimSinh t)               = rnfFloatingType t+rnfPrimFun (PrimCosh t)               = rnfFloatingType t+rnfPrimFun (PrimTanh t)               = rnfFloatingType t+rnfPrimFun (PrimAsinh t)              = rnfFloatingType t+rnfPrimFun (PrimAcosh t)              = rnfFloatingType t+rnfPrimFun (PrimAtanh t)              = rnfFloatingType t+rnfPrimFun (PrimExpFloating t)        = rnfFloatingType t+rnfPrimFun (PrimSqrt t)               = rnfFloatingType t+rnfPrimFun (PrimLog t)                = rnfFloatingType t+rnfPrimFun (PrimFPow t)               = rnfFloatingType t+rnfPrimFun (PrimLogBase t)            = rnfFloatingType t+rnfPrimFun (PrimTruncate f i)         = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimRound f i)            = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimFloor f i)            = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimCeiling f i)          = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimIsNaN t)              = rnfFloatingType t+rnfPrimFun (PrimIsInfinite t)         = rnfFloatingType t+rnfPrimFun (PrimAtan2 t)              = rnfFloatingType t+rnfPrimFun (PrimLt t)                 = rnfSingleType t+rnfPrimFun (PrimGt t)                 = rnfSingleType t+rnfPrimFun (PrimLtEq t)               = rnfSingleType t+rnfPrimFun (PrimGtEq t)               = rnfSingleType t+rnfPrimFun (PrimEq t)                 = rnfSingleType t+rnfPrimFun (PrimNEq t)                = rnfSingleType t+rnfPrimFun (PrimMax t)                = rnfSingleType t+rnfPrimFun (PrimMin t)                = rnfSingleType t+rnfPrimFun PrimLAnd                   = ()+rnfPrimFun PrimLOr                    = ()+rnfPrimFun PrimLNot                   = ()+rnfPrimFun (PrimFromIntegral i n)     = rnfIntegralType i `seq` rnfNumType n+rnfPrimFun (PrimToFloating n f)       = rnfNumType n `seq` rnfFloatingType f+++-- Template Haskell+-- ================++type LiftAcc acc = forall aenv a. acc aenv a -> Q (TExp (acc aenv a))++liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t))+liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftALeftHandSide lhs) $$(liftPreOpenAfun liftA f) ||]+liftPreOpenAfun liftA (Abody b)    = [|| Abody $$(liftA b) ||]++liftPreOpenAcc+    :: forall acc aenv a.+       HasArraysR acc+    => LiftAcc acc+    -> PreOpenAcc acc aenv a+    -> Q (TExp (PreOpenAcc acc aenv a))+liftPreOpenAcc liftA pacc =+  let+      liftE :: OpenExp env aenv t -> Q (TExp (OpenExp env aenv t))+      liftE = liftOpenExp++      liftF :: OpenFun env aenv t -> Q (TExp (OpenFun env aenv t))+      liftF = liftOpenFun++      liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f))+      liftAF = liftPreOpenAfun liftA++      liftB :: ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> Q (TExp (Boundary aenv (Array sh e)))+      liftB = liftBoundary++  in+  case pacc of+    Alet lhs bnd body         -> [|| Alet $$(liftALeftHandSide lhs) $$(liftA bnd) $$(liftA body) ||]+    Avar var                  -> [|| Avar $$(liftArrayVar var) ||]+    Apair as bs               -> [|| Apair $$(liftA as) $$(liftA bs) ||]+    Anil                      -> [|| Anil ||]+    Apply repr f a            -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||]+    Aforeign repr asm f a     -> [|| Aforeign $$(liftArraysR repr) $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||]+    Acond p t e               -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]+    Awhile p f a              -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]+    Use repr a                -> [|| Use $$(liftArrayR repr) $$(liftArray repr a) ||]+    Unit tp e                 -> [|| Unit $$(liftTypeR tp) $$(liftE e) ||]+    Reshape shr sh a          -> [|| Reshape $$(liftShapeR shr) $$(liftE sh) $$(liftA a) ||]+    Generate repr sh f        -> [|| Generate $$(liftArrayR repr) $$(liftE sh) $$(liftF f) ||]+    Transform repr sh p f a   -> [|| Transform $$(liftArrayR repr) $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||]+    Replicate slix sl a       -> [|| Replicate $$(liftSliceIndex slix) $$(liftE sl) $$(liftA a) ||]+    Slice slix a sh           -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||]+    Map tp f a                -> [|| Map $$(liftTypeR tp) $$(liftF f) $$(liftA a) ||]+    ZipWith tp f a b          -> [|| ZipWith $$(liftTypeR tp) $$(liftF f) $$(liftA a) $$(liftA b) ||]+    Fold f z a                -> [|| Fold $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) ||]+    FoldSeg i f z a s         -> [|| FoldSeg $$(liftIntegralType i) $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) $$(liftA s) ||]+    Scan d f z a              -> [|| Scan  $$(liftDirection d) $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) ||]+    Scan' d f z a             -> [|| Scan' $$(liftDirection d) $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Permute f d p a           -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||]+    Backpermute shr sh p a    -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftF p) $$(liftA a) ||]+    Stencil sr tp f b a       ->+      let+        TupRsingle (ArrayR shr _) = arraysR a+        repr = ArrayR shr $ stencilEltR sr+      in [|| Stencil $$(liftStencilR sr) $$(liftTypeR tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||]+    Stencil2 sr1 sr2 tp f b1 a1 b2 a2 ->+      let+        TupRsingle (ArrayR shr _) = arraysR a1+        repr1 = ArrayR shr $ stencilEltR sr1+        repr2 = ArrayR shr $ stencilEltR sr2+      in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTypeR tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||]+++liftALeftHandSide :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv'))+liftALeftHandSide = liftLeftHandSide liftArrayR++liftArrayVar :: ArrayVar aenv a -> Q (TExp (ArrayVar aenv a))+liftArrayVar = liftVar liftArrayR++liftDirection :: Direction -> Q (TExp Direction)+liftDirection LeftToRight = [|| LeftToRight ||]+liftDirection RightToLeft = [|| RightToLeft ||]++liftMaybe :: (a -> Q (TExp a)) -> Maybe a -> Q (TExp (Maybe a))+liftMaybe _ Nothing  = [|| Nothing ||]+liftMaybe f (Just x) = [|| Just $$(f x) ||]++liftList :: (a -> Q (TExp a)) -> [a] -> Q (TExp [a])+liftList _ []     = [|| [] ||]+liftList f (x:xs) = [|| $$(f x) : $$(liftList f xs) ||]++liftOpenFun+    :: OpenFun env aenv t+    -> Q (TExp (OpenFun env aenv t))+liftOpenFun (Lam lhs f)  = [|| Lam $$(liftELeftHandSide lhs) $$(liftOpenFun f) ||]+liftOpenFun (Body b)     = [|| Body $$(liftOpenExp b) ||]++liftOpenExp+    :: forall env aenv t.+       OpenExp env aenv t+    -> Q (TExp (OpenExp env aenv t))+liftOpenExp pexp =+  let+      liftE :: OpenExp env aenv e -> Q (TExp (OpenExp env aenv e))+      liftE = liftOpenExp++      liftF :: OpenFun env aenv f -> Q (TExp (OpenFun env aenv f))+      liftF = liftOpenFun+  in+  case pexp of+    Let lhs bnd body          -> [|| Let $$(liftELeftHandSide lhs) $$(liftOpenExp bnd) $$(liftOpenExp body) ||]+    Evar var                  -> [|| Evar $$(liftExpVar var) ||]+    Foreign repr asm f x      -> [|| Foreign $$(liftTypeR repr) $$(liftForeign asm) $$(liftOpenFun f) $$(liftE x) ||]+    Const tp c                -> [|| Const $$(liftScalarType tp) $$(liftElt (TupRsingle tp) c) ||]+    Undef tp                  -> [|| Undef $$(liftScalarType tp) ||]+    Pair a b                  -> [|| Pair $$(liftE a) $$(liftE b) ||]+    Nil                       -> [|| Nil ||]+    VecPack   vecr e          -> [|| VecPack   $$(liftVecR vecr) $$(liftE e) ||]+    VecUnpack vecr e          -> [|| VecUnpack $$(liftVecR vecr) $$(liftE e) ||]+    IndexSlice slice slix sh  -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||]+    IndexFull slice slix sl   -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||]+    ToIndex shr sh ix         -> [|| ToIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||]+    FromIndex shr sh ix       -> [|| FromIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||]+    Case p rhs def            -> [|| Case $$(liftE p) $$(liftList (\(t,c) -> [|| (t, $$(liftE c)) ||]) rhs) $$(liftMaybe liftE def) ||]+    Cond p t e                -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||]+    While p f x               -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||]+    PrimConst t               -> [|| PrimConst $$(liftPrimConst t) ||]+    PrimApp f x               -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||]+    Index a ix                -> [|| Index $$(liftArrayVar a) $$(liftE ix) ||]+    LinearIndex a ix          -> [|| LinearIndex $$(liftArrayVar a) $$(liftE ix) ||]+    Shape a                   -> [|| Shape $$(liftArrayVar a) ||]+    ShapeSize shr ix          -> [|| ShapeSize $$(liftShapeR shr) $$(liftE ix) ||]+    Coerce t1 t2 e            -> [|| Coerce $$(liftScalarType t1) $$(liftScalarType t2) $$(liftE e) ||]++liftELeftHandSide :: ELeftHandSide t env env' -> Q (TExp (ELeftHandSide t env env'))+liftELeftHandSide = liftLeftHandSide liftScalarType++liftExpVar :: ExpVar env t -> Q (TExp (ExpVar env t))+liftExpVar = liftVar liftScalarType++liftBoundary+    :: forall aenv sh e.+       ArrayR (Array sh e)+    -> Boundary aenv (Array sh e)+    -> Q (TExp (Boundary aenv (Array sh e)))+liftBoundary _             Clamp        = [|| Clamp ||]+liftBoundary _             Mirror       = [|| Mirror ||]+liftBoundary _             Wrap         = [|| Wrap ||]+liftBoundary (ArrayR _ tp) (Constant v) = [|| Constant $$(liftElt tp v) ||]+liftBoundary _             (Function f) = [|| Function $$(liftOpenFun f) ||]++liftPrimConst :: PrimConst c -> Q (TExp (PrimConst c))+liftPrimConst (PrimMinBound t) = [|| PrimMinBound $$(liftBoundedType t) ||]+liftPrimConst (PrimMaxBound t) = [|| PrimMaxBound $$(liftBoundedType t) ||]+liftPrimConst (PrimPi t)       = [|| PrimPi $$(liftFloatingType t) ||]++liftPrimFun :: PrimFun f -> Q (TExp (PrimFun f))+liftPrimFun (PrimAdd t)                = [|| PrimAdd $$(liftNumType t) ||]+liftPrimFun (PrimSub t)                = [|| PrimSub $$(liftNumType t) ||]+liftPrimFun (PrimMul t)                = [|| PrimMul $$(liftNumType t) ||]+liftPrimFun (PrimNeg t)                = [|| PrimNeg $$(liftNumType t) ||]+liftPrimFun (PrimAbs t)                = [|| PrimAbs $$(liftNumType t) ||]+liftPrimFun (PrimSig t)                = [|| PrimSig $$(liftNumType t) ||]+liftPrimFun (PrimQuot t)               = [|| PrimQuot $$(liftIntegralType t) ||]+liftPrimFun (PrimRem t)                = [|| PrimRem $$(liftIntegralType t) ||]+liftPrimFun (PrimQuotRem t)            = [|| PrimQuotRem $$(liftIntegralType t) ||]+liftPrimFun (PrimIDiv t)               = [|| PrimIDiv $$(liftIntegralType t) ||]+liftPrimFun (PrimMod t)                = [|| PrimMod $$(liftIntegralType t) ||]+liftPrimFun (PrimDivMod t)             = [|| PrimDivMod $$(liftIntegralType t) ||]+liftPrimFun (PrimBAnd t)               = [|| PrimBAnd $$(liftIntegralType t) ||]+liftPrimFun (PrimBOr t)                = [|| PrimBOr $$(liftIntegralType t) ||]+liftPrimFun (PrimBXor t)               = [|| PrimBXor $$(liftIntegralType t) ||]+liftPrimFun (PrimBNot t)               = [|| PrimBNot $$(liftIntegralType t) ||]+liftPrimFun (PrimBShiftL t)            = [|| PrimBShiftL $$(liftIntegralType t) ||]+liftPrimFun (PrimBShiftR t)            = [|| PrimBShiftR $$(liftIntegralType t) ||]+liftPrimFun (PrimBRotateL t)           = [|| PrimBRotateL $$(liftIntegralType t) ||]+liftPrimFun (PrimBRotateR t)           = [|| PrimBRotateR $$(liftIntegralType t) ||]+liftPrimFun (PrimPopCount t)           = [|| PrimPopCount $$(liftIntegralType t) ||]+liftPrimFun (PrimCountLeadingZeros t)  = [|| PrimCountLeadingZeros $$(liftIntegralType t) ||]+liftPrimFun (PrimCountTrailingZeros t) = [|| PrimCountTrailingZeros $$(liftIntegralType t) ||]+liftPrimFun (PrimFDiv t)               = [|| PrimFDiv $$(liftFloatingType t) ||]+liftPrimFun (PrimRecip t)              = [|| PrimRecip $$(liftFloatingType t) ||]+liftPrimFun (PrimSin t)                = [|| PrimSin $$(liftFloatingType t) ||]+liftPrimFun (PrimCos t)                = [|| PrimCos $$(liftFloatingType t) ||]+liftPrimFun (PrimTan t)                = [|| PrimTan $$(liftFloatingType t) ||]+liftPrimFun (PrimAsin t)               = [|| PrimAsin $$(liftFloatingType t) ||]+liftPrimFun (PrimAcos t)               = [|| PrimAcos $$(liftFloatingType t) ||]+liftPrimFun (PrimAtan t)               = [|| PrimAtan $$(liftFloatingType t) ||]+liftPrimFun (PrimSinh t)               = [|| PrimSinh $$(liftFloatingType t) ||]+liftPrimFun (PrimCosh t)               = [|| PrimCosh $$(liftFloatingType t) ||]+liftPrimFun (PrimTanh t)               = [|| PrimTanh $$(liftFloatingType t) ||]+liftPrimFun (PrimAsinh t)              = [|| PrimAsinh $$(liftFloatingType t) ||]+liftPrimFun (PrimAcosh t)              = [|| PrimAcosh $$(liftFloatingType t) ||]+liftPrimFun (PrimAtanh t)              = [|| PrimAtanh $$(liftFloatingType t) ||]+liftPrimFun (PrimExpFloating t)        = [|| PrimExpFloating $$(liftFloatingType t) ||]+liftPrimFun (PrimSqrt t)               = [|| PrimSqrt $$(liftFloatingType t) ||]+liftPrimFun (PrimLog t)                = [|| PrimLog $$(liftFloatingType t) ||]+liftPrimFun (PrimFPow t)               = [|| PrimFPow $$(liftFloatingType t) ||]+liftPrimFun (PrimLogBase t)            = [|| PrimLogBase $$(liftFloatingType t) ||]+liftPrimFun (PrimTruncate ta tb)       = [|| PrimTruncate $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimRound ta tb)          = [|| PrimRound $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimFloor ta tb)          = [|| PrimFloor $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimCeiling ta tb)        = [|| PrimCeiling $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimIsNaN t)              = [|| PrimIsNaN $$(liftFloatingType t) ||]+liftPrimFun (PrimIsInfinite t)         = [|| PrimIsInfinite $$(liftFloatingType t) ||]+liftPrimFun (PrimAtan2 t)              = [|| PrimAtan2 $$(liftFloatingType t) ||]+liftPrimFun (PrimLt t)                 = [|| PrimLt $$(liftSingleType t) ||]+liftPrimFun (PrimGt t)                 = [|| PrimGt $$(liftSingleType t) ||]+liftPrimFun (PrimLtEq t)               = [|| PrimLtEq $$(liftSingleType t) ||]+liftPrimFun (PrimGtEq t)               = [|| PrimGtEq $$(liftSingleType t) ||]+liftPrimFun (PrimEq t)                 = [|| PrimEq $$(liftSingleType t) ||]+liftPrimFun (PrimNEq t)                = [|| PrimNEq $$(liftSingleType t) ||]+liftPrimFun (PrimMax t)                = [|| PrimMax $$(liftSingleType t) ||]+liftPrimFun (PrimMin t)                = [|| PrimMin $$(liftSingleType t) ||]+liftPrimFun PrimLAnd                   = [|| PrimLAnd ||]+liftPrimFun PrimLOr                    = [|| PrimLOr ||]+liftPrimFun PrimLNot                   = [|| PrimLNot ||]+liftPrimFun (PrimFromIntegral ta tb)   = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||]+liftPrimFun (PrimToFloating ta tb)     = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||]+++showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String+showPreAccOp Alet{}              = "Alet"+showPreAccOp (Avar (Var _ ix))   = "Avar a" ++ show (idxToInt ix)+showPreAccOp (Use aR a)          = "Use " ++ showArrayShort 5 (showsElt (arrayRtype aR)) aR a+showPreAccOp Apply{}             = "Apply"+showPreAccOp Aforeign{}          = "Aforeign"+showPreAccOp Acond{}             = "Acond"+showPreAccOp Awhile{}            = "Awhile"+showPreAccOp Apair{}             = "Apair"+showPreAccOp Anil                = "Anil"+showPreAccOp Unit{}              = "Unit"+showPreAccOp Generate{}          = "Generate"+showPreAccOp Transform{}         = "Transform"+showPreAccOp Reshape{}           = "Reshape"+showPreAccOp Replicate{}         = "Replicate"+showPreAccOp Slice{}             = "Slice"+showPreAccOp Map{}               = "Map"+showPreAccOp ZipWith{}           = "ZipWith"+showPreAccOp (Fold _ z _)        = "Fold" ++ maybe "1" (const "") z+showPreAccOp (FoldSeg _ _ z _ _) = "Fold" ++ maybe "1" (const "") z ++ "Seg"+showPreAccOp (Scan d _ z _)      = "Scan" ++ showsDirection d (maybe "1" (const "") z)+showPreAccOp (Scan' d _ _ _)     = "Scan" ++ showsDirection d "'"+showPreAccOp Permute{}           = "Permute"+showPreAccOp Backpermute{}       = "Backpermute"+showPreAccOp Stencil{}           = "Stencil"+showPreAccOp Stencil2{}          = "Stencil2"++showsDirection :: Direction -> ShowS+showsDirection LeftToRight = ('l':)+showsDirection RightToLeft = ('r':)++showExpOp :: forall aenv env t. OpenExp aenv env t -> String+showExpOp Let{}             = "Let"+showExpOp (Evar (Var _ ix)) = "Var x" ++ show (idxToInt ix)+showExpOp (Const tp c)      = "Const " ++ showElt (TupRsingle tp) c+showExpOp Undef{}           = "Undef"+showExpOp Foreign{}         = "Foreign"+showExpOp Pair{}            = "Pair"+showExpOp Nil{}             = "Nil"+showExpOp VecPack{}         = "VecPack"+showExpOp VecUnpack{}       = "VecUnpack"+showExpOp IndexSlice{}      = "IndexSlice"+showExpOp IndexFull{}       = "IndexFull"+showExpOp ToIndex{}         = "ToIndex"+showExpOp FromIndex{}       = "FromIndex"+showExpOp Case{}            = "Case"+showExpOp Cond{}            = "Cond"+showExpOp While{}           = "While"+showExpOp PrimConst{}       = "PrimConst"+showExpOp PrimApp{}         = "PrimApp"+showExpOp Index{}           = "Index"+showExpOp LinearIndex{}     = "LinearIndex"+showExpOp Shape{}           = "Shape"+showExpOp ShapeSize{}       = "ShapeSize"+showExpOp Coerce{}          = "Coerce" 

@@ -0,0 +1,90 @@+{-# LANGUAGE EmptyCase           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST.Environment+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.AST.Environment+  where++import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.Error+++-- Valuation for an environment+--+data Val env where+  Empty :: Val ()+  Push  :: Val env -> t -> Val (env, t)++-- Push a set of variables into an environment+--+push :: Val env -> (LeftHandSide s t env env', t) -> Val env'+push env (LeftHandSideWildcard _, _     ) = env+push env (LeftHandSideSingle _  , a     ) = env `Push` a+push env (LeftHandSidePair l1 l2, (a, b)) = push env (l1, a) `push` (l2, b)++-- Projection of a value from a valuation using a de Bruijn index+--+prj :: Idx env t -> Val env -> t+prj ZeroIdx       (Push _   v) = v+prj (SuccIdx idx) (Push val _) = prj idx val+++-- The type of shifting terms from one context into another+--+-- This is defined as a newtype, as a type synonym containing a forall+-- quantifier may give issues with impredicative polymorphism, which GHC+-- does not support.+--+newtype env :> env' = Weaken { (>:>) :: forall t'. Idx env t' -> Idx env' t' } -- Weak or Weaken++weakenId :: env :> env+weakenId = Weaken id++weakenSucc' :: env :> env' -> env :> (env', t)+weakenSucc' (Weaken f) = Weaken (SuccIdx . f)++weakenSucc :: (env, t) :> env' -> env :> env'+weakenSucc (Weaken f) = Weaken (f . SuccIdx)++weakenEmpty :: () :> env'+weakenEmpty = Weaken $ \case { }++sink :: forall env env' t. env :> env' -> (env, t) :> (env', t)+sink (Weaken f) = Weaken g+  where+    g :: Idx (env, t) t' -> Idx (env', t) t'+    g ZeroIdx      = ZeroIdx+    g (SuccIdx ix) = SuccIdx $ f ix++infixr 9 .>+(.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3+(.>) (Weaken f) (Weaken g) = Weaken (f . g)++sinkWithLHS :: HasCallStack => LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2'+sinkWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k+sinkWithLHS (LeftHandSideSingle _)   (LeftHandSideSingle _)   k = sink k+sinkWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = sinkWithLHS b1 b2 $ sinkWithLHS a1 a2 k+sinkWithLHS _ _ _ = internalError "left hand sides do not match"++weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env'+weakenWithLHS = go weakenId+  where+    go :: env2 :> env' -> LeftHandSide s arrs env1 env2 -> env1 :> env'+    go k (LeftHandSideWildcard _) = k+    go k (LeftHandSideSingle _)   = weakenSucc k+    go k (LeftHandSidePair l1 l2) = go (go k l2) l1+

@@ -0,0 +1,44 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST.Idx+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Typed de Bruijn indices+--++module Data.Array.Accelerate.AST.Idx+  where++import Language.Haskell.TH++-- De Bruijn variable index projecting a specific type from a type+-- environment.  Type environments are nested pairs (..((), t1), t2, ..., tn).+--+data Idx env t where+  ZeroIdx ::              Idx (env, t) t+  SuccIdx :: Idx env t -> Idx (env, s) t++data PairIdx p a where+  PairIdxLeft  :: PairIdx (a, b) a+  PairIdxRight :: PairIdx (a, b) b+++idxToInt :: Idx env t -> Int+idxToInt ZeroIdx       = 0+idxToInt (SuccIdx idx) = 1 + idxToInt idx++rnfIdx :: Idx env t -> ()+rnfIdx ZeroIdx      = ()+rnfIdx (SuccIdx ix) = rnfIdx ix++liftIdx :: Idx env t -> Q (TExp (Idx env t))+liftIdx ZeroIdx      = [|| ZeroIdx ||]+liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||]+

@@ -0,0 +1,62 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes      #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST.LeftHandSide+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.AST.LeftHandSide+  where++import Data.Array.Accelerate.Representation.Type++import Language.Haskell.TH+++data Exists f where+  Exists :: f a -> Exists f++data LeftHandSide s v env env' where+  LeftHandSideSingle+    :: s v+    -> LeftHandSide s v env (env, v)++  LeftHandSideWildcard+    :: TupR s v+    -> LeftHandSide s v env env++  LeftHandSidePair+    :: LeftHandSide s v1       env  env'+    -> LeftHandSide s v2       env' env''+    -> LeftHandSide s (v1, v2) env  env''++pattern LeftHandSideUnit+    :: ()                   -- required+    => (env' ~ env, v ~ ()) -- provided+    => LeftHandSide s v env env'+pattern LeftHandSideUnit = LeftHandSideWildcard TupRunit++lhsToTupR :: LeftHandSide s v env env' -> TupR s v+lhsToTupR (LeftHandSideSingle s)   = TupRsingle s+lhsToTupR (LeftHandSideWildcard r) = r+lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs)++rnfLeftHandSide :: (forall b. s b -> ()) -> LeftHandSide s v env env' -> ()+rnfLeftHandSide f (LeftHandSideWildcard r) = rnfTupR f r+rnfLeftHandSide f (LeftHandSideSingle s)   = f s+rnfLeftHandSide f (LeftHandSidePair as bs) = rnfLeftHandSide f as `seq` rnfLeftHandSide f bs++liftLeftHandSide :: (forall u. s u -> Q (TExp (s u))) -> LeftHandSide s v env env' -> Q (TExp (LeftHandSide s v env env'))+liftLeftHandSide f (LeftHandSideSingle s)   = [|| LeftHandSideSingle $$(f s) ||]+liftLeftHandSide f (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftTupR f r) ||]+liftLeftHandSide f (LeftHandSidePair as bs) = [|| LeftHandSidePair $$(liftLeftHandSide f as) $$(liftLeftHandSide f bs) ||]+

@@ -0,0 +1,44 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE RankNTypes      #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST.Var+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.AST.Var+  where++import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.AST.Idx++import Language.Haskell.TH+++data Var  s env t = Var (s t) (Idx env t)+type Vars s env   = TupR (Var s env)++varsType :: Vars s env t -> TupR s t+varsType TupRunit               = TupRunit+varsType (TupRsingle (Var t _)) = TupRsingle t+varsType (TupRpair a b)         = TupRpair (varsType a) (varsType b)+++rnfVar :: (forall b. s b -> ()) -> Var s env t -> ()+rnfVar f (Var t idx) = f t `seq` rnfIdx idx++rnfVars :: (forall b. s b -> ()) -> Vars s env t -> ()+rnfVars f = rnfTupR (rnfVar f)++liftVar :: (forall b. s b -> Q (TExp (s b))) -> Var s env t -> Q (TExp (Var s env t))+liftVar f (Var s idx) = [|| Var $$(f s) $$(liftIdx idx) ||]++liftVars :: (forall b. s b -> Q (TExp (s b))) -> Vars s env t -> Q (TExp (Vars s env t))+liftVars f = liftTupR (liftVar f)+

@@ -1,15 +1,18 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-} {-# LANGUAGE PatternGuards       #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Hash--- Copyright   : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright   : [2017..2020] The Accelerate Team -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -18,32 +21,38 @@    -- hashing expressions   Hash,-  hashPreOpenAcc,-  hashPreOpenFun,-  hashPreOpenExp,+  HashOptions(..), defaultHashOptions,+  hashPreOpenAcc, hashPreOpenAccWith,+  hashOpenFun, hashOpenExp,    -- auxiliary   EncodeAcc,-  encodePreOpenAcc, encodeOpenAcc,-  encodePreOpenExp, encodeOpenExp,-  encodePreOpenFun,+  encodePreOpenAcc,+  encodeOpenExp,+  encodeOpenFun,+  encodeArraysType,   hashQ,  ) where  import Data.Array.Accelerate.AST+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Hash.TH-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )-import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Slice+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type+import Data.Primitive.Vec  import Crypto.Hash-import Data.Bits import Data.ByteString.Builder import Data.ByteString.Builder.Extra+import Data.ByteString.Short.Internal                               ( ShortByteString(..) ) import Data.Monoid-import Foreign.C.Types import System.IO.Unsafe                                             ( unsafePerformIO ) import System.Mem.StableName                                        ( hashStableName, makeStableName ) import Prelude                                                      hiding ( exp )@@ -54,107 +63,157 @@  type Hash = Digest SHA3_256 -hashPreOpenAcc :: EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash-hashPreOpenAcc encodeAcc = hashlazy . toLazyByteString . encodePreOpenAcc encodeAcc+data HashOptions = HashOptions+  { perfect :: Bool+    -- ^ Should the hash function include _all_ substructure, recursively?+    --+    -- Set to true (the default) if you want a truly unique fingerprint for+    -- the entire expression:+    --+    -- Example:+    --+    -- xs, ys :: Acc (Vector Float)+    -- xs = fill (constant (Z:.10)) 1.0+    -- ys = fill (constant (Z:.20)) 1.0+    --+    -- with perfect=True:+    --+    --   hash xs = 2e1f91aca4c476d13b36f22462e73c15bbdd9fcacb0d4996280f6004058e9732+    --   hash ys = 2fce5c849b6c652192b09aaeafdc8029e57b9f006c1ecd79ccf9114f349aaf9e+    --+    -- However, for a code generating backend the object code used to+    -- evaluate both of these expressions is likely to be identical.+    --+    -- Setting perfect=False results in:+    --+    --   hash xs = hash ys = f97944b0ec64ab8aa989fd60c8b50e7ec3eff759d22d2b340039d837d74dfc3c+    --+    -- Note that to be useful the provided 'EncodeAcc' function must also+    -- understand this option, and the consumer of the hash value must be+    -- agnostic to the elided details.+  }+  deriving Show -hashPreOpenFun :: EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash-hashPreOpenFun encodeAcc = hashlazy . toLazyByteString . encodePreOpenFun encodeAcc+defaultHashOptions :: HashOptions+defaultHashOptions = HashOptions True -hashPreOpenExp :: EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash-hashPreOpenExp encodeAcc = hashlazy . toLazyByteString . encodePreOpenExp encodeAcc +{-# INLINEABLE hashPreOpenAcc #-}+hashPreOpenAcc :: HasArraysR acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash+hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions +{-# INLINEABLE hashPreOpenAccWith #-}+hashPreOpenAccWith :: HasArraysR acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash+hashPreOpenAccWith options encodeAcc+  = hashlazy+  . toLazyByteString+  . encodePreOpenAcc options encodeAcc++{-# INLINEABLE hashOpenFun #-}+hashOpenFun :: OpenFun env aenv f -> Hash+hashOpenFun+  = hashlazy+  . toLazyByteString+  . encodeOpenFun++{-# INLINEABLE hashOpenExp #-}+hashOpenExp :: OpenExp env aenv t -> Hash+hashOpenExp+  = hashlazy+  . toLazyByteString+  . encodeOpenExp++ -- Array computations -- ------------------ -type EncodeAcc acc = forall aenv a. acc aenv a -> Builder--{-# INLINE encodeOpenAcc #-}-encodeOpenAcc :: OpenAcc aenv arrs -> Builder-encodeOpenAcc (OpenAcc pacc) = encodePreOpenAcc encodeOpenAcc pacc+type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder -{-# INLINE encodePreOpenAcc #-}+{-# INLINEABLE encodePreOpenAcc #-} encodePreOpenAcc-    :: forall acc aenv arrs.-       EncodeAcc acc+    :: forall acc aenv arrs. HasArraysR acc+    => HashOptions+    -> EncodeAcc acc     -> PreOpenAcc acc aenv arrs     -> Builder-encodePreOpenAcc encodeAcc pacc =+encodePreOpenAcc options encodeAcc pacc =   let-      {-# INLINE travA #-}-      travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder-      travA a = encodeArraysType (arrays (undefined::a)) <> encodeAcc a+      travA :: forall aenv' a. acc aenv' a -> Builder+      travA = encodeAcc options -      {-# INLINE travE #-}-      travE :: PreOpenExp acc env' aenv' e -> Builder-      travE = encodePreOpenExp encodeAcc+      travAF :: PreOpenAfun acc aenv' f -> Builder+      travAF = encodePreOpenAfun options encodeAcc -      {-# INLINE travF #-}-      travF :: PreOpenFun acc env' aenv' f -> Builder-      travF = encodePreOpenFun encodeAcc+      travE :: OpenExp env' aenv' e -> Builder+      travE = encodeOpenExp -      {-# INLINE travB #-}-      travB :: PreBoundary acc aenv' (Array sh e) -> Builder-      travB = encodePreBoundary encodeAcc+      travF :: OpenFun env' aenv' f -> Builder+      travF = encodeOpenFun -      {-# INLINE nacl #-}-      nacl :: Arrays arrs => Builder-      nacl = encodeArraysType (arrays (undefined::arrs))+      travD :: Direction -> Builder+      travD LeftToRight = intHost $(hashQ "L")+      travD RightToLeft = intHost $(hashQ "R")++      deep :: Builder -> Builder+      deep | perfect options = id+           | otherwise       = const mempty++      deepE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder+      deepE e+        | perfect options = travE e+        | otherwise       = encodeTypeR $ expType e   in   case pacc of-    Alet bnd body               -> intHost $(hashQ "Alet")        <> travA bnd <> travA body-    Avar v                      -> intHost $(hashQ "Avar")        <> nacl <> encodeIdx v-    Atuple t                    -> intHost $(hashQ "Atuple")      <> nacl <> encodeAtuple encodeAcc t-    Aprj ix a                   -> intHost $(hashQ "Aprj")        <> nacl <> encodeTupleIdx ix <> travA a-    Apply f a                   -> intHost $(hashQ "Apply")       <> nacl <> encodePreOpenAfun encodeAcc f <> travA a-    Aforeign _ f a              -> intHost $(hashQ "Aforeign")    <> nacl <> encodePreOpenAfun encodeAcc f <> travA a-    Use a                       -> intHost $(hashQ "Use")         <> encodeArrays (arrays (undefined::arrs)) a-    Awhile p f a                -> intHost $(hashQ "Awhile")      <> encodePreOpenAfun encodeAcc f <> encodePreOpenAfun encodeAcc p <> travA a-    Unit e                      -> intHost $(hashQ "Unit")        <> travE e-    Generate e f                -> intHost $(hashQ "Generate")    <> travE e  <> travF f-    Acond e a1 a2               -> intHost $(hashQ "Acond")       <> travE e  <> travA a1 <> travA a2-    Reshape sh a                -> intHost $(hashQ "Reshape")     <> travE sh <> travA a-    Transform sh f1 f2 a        -> intHost $(hashQ "Transform")   <> travE sh <> travF f1 <> travF f2 <> travA a-    Replicate spec ix a         -> intHost $(hashQ "Replicate")   <> travE ix <> travA a  <> encodeSliceIndex spec-    Slice spec a ix             -> intHost $(hashQ "Slice")       <> travE ix <> travA a  <> encodeSliceIndex spec-    Map f a                     -> intHost $(hashQ "Map")         <> travF f  <> travA a-    ZipWith f a1 a2             -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2-    Fold f e a                  -> intHost $(hashQ "Fold")        <> travF f  <> travE e  <> travA a-    Fold1 f a                   -> intHost $(hashQ "Fold1")       <> travF f  <> travA a-    FoldSeg f e a s             -> intHost $(hashQ "FoldSeg")     <> travF f  <> travE e  <> travA a  <> travA s-    Fold1Seg f a s              -> intHost $(hashQ "Fold1Seg")    <> travF f  <> travA a  <> travA s-    Scanl f e a                 -> intHost $(hashQ "Scanl")       <> travF f  <> travE e  <> travA a-    Scanl' f e a                -> intHost $(hashQ "Scanl'")      <> travF f  <> travE e  <> travA a-    Scanl1 f a                  -> intHost $(hashQ "Scanl1")      <> travF f  <> travA a-    Scanr f e a                 -> intHost $(hashQ "Scanr")       <> travF f  <> travE e  <> travA a-    Scanr' f e a                -> intHost $(hashQ "Scanr'")      <> travF f  <> travE e  <> travA a-    Scanr1 f a                  -> intHost $(hashQ "Scanr1")      <> travF f  <> travA a-    Backpermute sh f a          -> intHost $(hashQ "Backpermute") <> travF f  <> travE sh <> travA a-    Permute f1 a1 f2 a2         -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2-    Stencil f b a               -> intHost $(hashQ "Stencil")     <> travF f  <> travB b  <> travA a-    Stencil2 f b1 a1 b2 a2      -> intHost $(hashQ "Stencil2")    <> travF f  <> travB b1 <> travA a1 <> travB b2 <> travA a2+    Alet lhs bnd body            -> intHost $(hashQ "Alet")        <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body+    Avar (Var repr v)            -> intHost $(hashQ "Avar")        <> encodeArrayType repr <> deep (encodeIdx v)+    Apair a1 a2                  -> intHost $(hashQ "Apair")       <> travA a1 <> travA a2+    Anil                         -> intHost $(hashQ "Anil")+    Apply _ f a                  -> intHost $(hashQ "Apply")       <> travAF f <> travA a+    Aforeign _ _ f a             -> intHost $(hashQ "Aforeign")    <> travAF f <> travA a+    Use repr a                   -> intHost $(hashQ "Use")         <> encodeArrayType repr <> deep (encodeArray a)+    Awhile p f a                 -> intHost $(hashQ "Awhile")      <> travAF f <> travAF p <> travA a+    Unit _ e                     -> intHost $(hashQ "Unit")        <> travE e+    Generate _ e f               -> intHost $(hashQ "Generate")    <> deepE e <> travF f+    -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool.+    -- We thus use `deep (travE e)` instead of `deepE e`.+    Acond e a1 a2                -> intHost $(hashQ "Acond")       <> deep (travE e) <> travA a1 <> travA a2+    Reshape _ sh a               -> intHost $(hashQ "Reshape")     <> deepE sh <> travA a+    Backpermute _ sh f a         -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f  <> travA a+    Transform _ sh f1 f2 a       -> intHost $(hashQ "Transform")   <> deepE sh <> travF f1 <> travF f2 <> travA a+    Replicate spec ix a          -> intHost $(hashQ "Replicate")   <> deepE ix <> travA a  <> encodeSliceIndex spec+    Slice spec a ix              -> intHost $(hashQ "Slice")       <> deepE ix <> travA a  <> encodeSliceIndex spec+    Map _ f a                    -> intHost $(hashQ "Map")         <> travF f  <> travA a+    ZipWith _ f a1 a2            -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2+    Fold f e a                   -> intHost $(hashQ "Fold")        <> travF f  <> encodeMaybe travE e  <> travA a+    FoldSeg _ f e a s            -> intHost $(hashQ "FoldSeg")     <> travF f  <> encodeMaybe travE e  <> travA a  <> travA s+    Scan  d f e a                -> intHost $(hashQ "Scan")        <> travD d  <> travF f  <> encodeMaybe travE e  <> travA a+    Scan' d f e a                -> intHost $(hashQ "Scan'")       <> travD d  <> travF f  <>           travE e  <> travA a+    Permute f1 a1 f2 a2          -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2+    Stencil s _ f b a            -> intHost $(hashQ "Stencil")     <> travF f  <> encodeBoundary (stencilEltR s) b  <> travA a+    Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2")  <> travF f  <> encodeBoundary (stencilEltR s1) b1 <> travA a1 <> encodeBoundary (stencilEltR s2) b2 <> travA a2  {--+{-# INLINEABLE encodePreOpenSeq #-} encodePreOpenSeq :: forall acc aenv senv arrs. EncodeAcc acc -> PreOpenSeq acc aenv senv arrs -> Int encodePreOpenSeq encodeAcc s =   let       travA :: acc aenv' a -> Builder       travA = encodeAcc -- XXX: plus type information? -      travE :: PreOpenExp acc env' aenv' e -> Builder-      travE = encodePreOpenExp encodeAcc+      travE :: OpenExp env' aenv' e -> Builder+      travE = encodeOpenExp encodeAcc        travAF :: PreOpenAfun acc aenv' f -> Builder       travAF = encodePreOpenAfun encodeAcc -      travF :: PreOpenFun acc env' aenv' f -> Builder-      travF = encodePreOpenFun encodeAcc+      travF :: OpenFun env' aenv' f -> Builder+      travF = encodeOpenFun encodeAcc        travS :: PreOpenSeq acc aenv senv' arrs' -> Builder       travS = encodePreOpenSeq encodeAcc        travV :: forall a. Arrays a => Idx senv' a -> Builder-      travV v = encodeArraysType (arrays (undefined::a)) <> encodeIdx v+      travV v = encodeArraysType (arrays @a) <> encodeIdx v        travP :: Producer acc aenv senv a -> Builder       travP p =@@ -179,61 +238,57 @@     Reify ix      -> intHost $(hashQ "Reify")      <> travV ix --} -{-# INLINE encodeIdx #-} encodeIdx :: Idx env t -> Builder encodeIdx = intHost . idxToInt -{-# INLINE encodeTupleIdx #-}-encodeTupleIdx :: TupleIdx tup e -> Builder-encodeTupleIdx = intHost . tupleIdxToInt+encodeArray :: Array sh e -> Builder+encodeArray ad = intHost . unsafePerformIO $! hashStableName <$> makeStableName ad -{-# INLINE encodeArrays #-}-encodeArrays :: ArraysR a -> a -> Builder-encodeArrays ArraysRunit         ()       = mempty-encodeArrays (ArraysRpair r1 r2) (a1, a2) = encodeArrays r1 a1 <> encodeArrays r2 a2-encodeArrays ArraysRarray        ad       = intHost . unsafePerformIO $! hashStableName `fmap` makeStableName ad+encodeTupR :: (forall b. s b -> Builder) -> TupR s a -> Builder+encodeTupR _ TupRunit         = intHost $(hashQ "TupRunit")+encodeTupR f (TupRpair r1 r2) = intHost $(hashQ "TupRpair")   <> encodeTupR f r1 <> encodeTupR f r2+encodeTupR f (TupRsingle s)   = intHost $(hashQ "TupRsingle") <> f s -{-# INLINE encodeArraysType #-}-encodeArraysType :: forall a. ArraysR a -> Builder-encodeArraysType ArraysRunit         = intHost $(hashQ "ArraysRunit")-encodeArraysType (ArraysRpair r1 r2) = intHost $(hashQ "ArraysRpair")  <> encodeArraysType r1 <> encodeArraysType r2-encodeArraysType ArraysRarray        = intHost $(hashQ "ArraysRarray") <> encodeArrayType (undefined::a)-  where-    {-# INLINE encodeArrayType #-}-    encodeArrayType :: forall sh e. (Shape sh, Elt e) => Array sh e -> Builder-    encodeArrayType _ = encodeTupleType (eltType (undefined::sh)) <> encodeTupleType (eltType (undefined::e))+encodeLeftHandSide :: (forall b. s b -> Builder) -> LeftHandSide s a env env' -> Builder+encodeLeftHandSide f (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeTupR f r+encodeLeftHandSide f (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair")     <> encodeLeftHandSide f r1 <> encodeLeftHandSide f r2+encodeLeftHandSide f (LeftHandSideSingle s)   = intHost $(hashQ "LeftHandSideArray")    <> f s -{-# INLINE encodeAtuple #-}-encodeAtuple :: EncodeAcc acc -> Atuple (acc aenv) a -> Builder-encodeAtuple _     NilAtup        = intHost $(hashQ "NilAtup")-encodeAtuple travA (SnocAtup t a) = intHost $(hashQ "SnocAtup") <> encodeAtuple travA t <> travA a+encodeArrayType :: ArrayR a -> Builder+encodeArrayType (ArrayR shr tp) = encodeShapeR shr <> encodeTypeR tp -{-# INLINE encodePreOpenAfun #-}-encodePreOpenAfun :: forall acc aenv f. EncodeAcc acc -> PreOpenAfun acc aenv f -> Builder-encodePreOpenAfun travA afun =-  let-      {-# INLINE travB #-}-      travB :: forall aenv' a. Arrays a => acc aenv' a -> Builder-      travB b = encodeArraysType (arrays (undefined::a)) <> travA b+encodeArraysType :: ArraysR arrs -> Builder+encodeArraysType = encodeTupR encodeArrayType -      {-# INLINE travL #-}-      travL :: forall aenv' a b. Arrays a => PreOpenAfun acc (aenv',a) b -> Builder-      travL l = encodeArraysType (arrays (undefined::a)) <> encodePreOpenAfun travA l+encodeShapeR :: ShapeR sh -> Builder+encodeShapeR = intHost . rank++encodePreOpenAfun+    :: forall acc aenv f.+       HashOptions+    -> EncodeAcc acc+    -> PreOpenAfun acc aenv f+    -> Builder+encodePreOpenAfun options travA afun =+  let+      travL :: forall aenv1 aenv2 a b. ALeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder+      travL lhs l = encodeLeftHandSide encodeArrayType lhs <> encodePreOpenAfun options travA l   in   case afun of-    Abody b -> intHost $(hashQ "Abody") <> travB b-    Alam  l -> intHost $(hashQ "Alam")  <> travL l+    Abody b    -> intHost $(hashQ "Abody") <> travA options b+    Alam lhs l -> intHost $(hashQ "Alam")  <> travL lhs  l  -{-# INLINE encodePreBoundary #-}-encodePreBoundary :: forall acc aenv sh e. EncodeAcc acc -> PreBoundary acc aenv (Array sh e) -> Builder-encodePreBoundary _ Wrap          = intHost $(hashQ "Wrap")-encodePreBoundary _ Clamp         = intHost $(hashQ "Clamp")-encodePreBoundary _ Mirror        = intHost $(hashQ "Mirror")-encodePreBoundary _ (Constant c)  = intHost $(hashQ "Constant") <> encodeConst (eltType (undefined::e)) c-encodePreBoundary h (Function f)  = intHost $(hashQ "Function") <> encodePreOpenFun h f+encodeBoundary+    :: TypeR e+    -> Boundary aenv (Array sh e)+    -> Builder+encodeBoundary _  Wrap          = intHost $(hashQ "Wrap")+encodeBoundary _  Clamp         = intHost $(hashQ "Clamp")+encodeBoundary _  Mirror        = intHost $(hashQ "Mirror")+encodeBoundary tp (Constant c)  = intHost $(hashQ "Constant") <> encodeConst tp c+encodeBoundary _  (Function f)  = intHost $(hashQ "Function") <> encodeOpenFun f -{-# INLINE encodeSliceIndex #-} encodeSliceIndex :: SliceIndex slix sl co sh -> Builder encodeSliceIndex SliceNil         = intHost $(hashQ "SliceNil") encodeSliceIndex (SliceAll r)     = intHost $(hashQ "SliceAll")   <> encodeSliceIndex r@@ -243,168 +298,96 @@ -- Scalar expressions -- ------------------ -{-# INLINE encodeOpenExp #-}-encodeOpenExp :: OpenExp env aenv exp -> Builder-encodeOpenExp = encodePreOpenExp encodeOpenAcc--{-# INLINE encodePreOpenExp #-}-encodePreOpenExp :: forall acc env aenv exp. EncodeAcc acc -> PreOpenExp acc env aenv exp -> Builder-encodePreOpenExp travA exp =+{-# INLINEABLE encodeOpenExp #-}+encodeOpenExp+    :: forall env aenv exp.+       OpenExp env aenv exp+    -> Builder+encodeOpenExp exp =   let-      {-# INLINE travE #-}-      travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder-      travE e =  encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA e--      {-# INLINE travF #-}-      travF :: PreOpenFun acc env' aenv' f -> Builder-      travF = encodePreOpenFun travA+      travE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder+      travE e = encodeOpenExp e -      {-# INLINE nacl #-}-      nacl :: Elt exp => Builder-      nacl = encodeTupleType (eltType (undefined::exp))+      travF :: OpenFun env' aenv' f -> Builder+      travF = encodeOpenFun   in   case exp of-    Let bnd body                -> intHost $(hashQ "Let")         <> travE bnd <> travE body-    Var ix                      -> intHost $(hashQ "Var")         <> nacl <> encodeIdx ix-    Tuple t                     -> intHost $(hashQ "Tuple")       <> nacl <> encodeTuple travA t-    Prj i e                     -> intHost $(hashQ "Prj")         <> nacl <> encodeTupleIdx i <> travE e -- XXX: here multiplied nacl by hashTupleIdx-    Const c                     -> intHost $(hashQ "Const")       <> encodeConst (eltType (undefined::exp)) c-    Undef                       -> intHost $(hashQ "Undef")-    IndexAny                    -> intHost $(hashQ "IndexAny")    <> nacl-    IndexNil                    -> intHost $(hashQ "IndexNil")-    IndexCons sh sz             -> intHost $(hashQ "IndexCons")   <> travE sh <> travE sz-    IndexHead sl                -> intHost $(hashQ "IndexHead")   <> travE sl-    IndexTail sl                -> intHost $(hashQ "IndexTail")   <> travE sl+    Let lhs bnd body            -> intHost $(hashQ "Let")         <> encodeLeftHandSide encodeScalarType lhs <> travE bnd <> travE body+    Evar (Var tp ix)            -> intHost $(hashQ "Evar")        <> encodeScalarType tp <> encodeIdx ix+    Nil                         -> intHost $(hashQ "Nil")+    Pair e1 e2                  -> intHost $(hashQ "Pair")        <> travE e1 <> travE e2+    VecPack   _ e               -> intHost $(hashQ "VecPack")     <> travE e+    VecUnpack _ e               -> intHost $(hashQ "VecUnpack")   <> travE e+    Const tp c                  -> intHost $(hashQ "Const")       <> encodeScalarConst tp c+    Undef tp                    -> intHost $(hashQ "Undef")       <> encodeScalarType tp     IndexSlice spec ix sh       -> intHost $(hashQ "IndexSlice")  <> travE ix <> travE sh <> encodeSliceIndex spec     IndexFull  spec ix sl       -> intHost $(hashQ "IndexFull")   <> travE ix <> travE sl <> encodeSliceIndex spec-    ToIndex sh i                -> intHost $(hashQ "ToIndex")     <> travE sh <> travE i-    FromIndex sh i              -> intHost $(hashQ "FromIndex")   <> travE sh <> travE i+    ToIndex _ sh i              -> intHost $(hashQ "ToIndex")     <> travE sh <> travE i+    FromIndex _ sh i            -> intHost $(hashQ "FromIndex")   <> travE sh <> travE i+    Case e rhs def              -> intHost $(hashQ "Case")        <> travE e  <> mconcat [ word8 t <> travE c | (t,c) <- rhs ] <> encodeMaybe travE def     Cond c t e                  -> intHost $(hashQ "Cond")        <> travE c  <> travE t  <> travE e     While p f x                 -> intHost $(hashQ "While")       <> travF p  <> travF f  <> travE x     PrimApp f x                 -> intHost $(hashQ "PrimApp")     <> encodePrimFun f <> travE x     PrimConst c                 -> intHost $(hashQ "PrimConst")   <> encodePrimConst c-    Index a ix                  -> intHost $(hashQ "Index")       <> travA a  <> travE ix-    LinearIndex a ix            -> intHost $(hashQ "LinearIndex") <> travA a  <> travE ix-    Shape a                     -> intHost $(hashQ "Shape")       <> travA a-    ShapeSize sh                -> intHost $(hashQ "ShapeSize")   <> travE sh-    Intersect sa sb             -> intHost $(hashQ "Intersect")   <> travE sa <> travE sb-    Union sa sb                 -> intHost $(hashQ "Union")       <> travE sa <> travE sb-    Foreign _ f e               -> intHost $(hashQ "Foreign")     <> travF f  <> travE e-    Coerce e                    -> intHost $(hashQ "Coerce")      <> travE e---{-# INLINE encodePreOpenFun #-}-encodePreOpenFun :: forall acc env aenv f. EncodeAcc acc -> PreOpenFun acc env aenv f -> Builder-encodePreOpenFun travA fun =-  let-      travB :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder-      travB b = encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA b+    Index a ix                  -> intHost $(hashQ "Index")       <> encodeArrayVar a <> travE ix+    LinearIndex a ix            -> intHost $(hashQ "LinearIndex") <> encodeArrayVar a <> travE ix+    Shape a                     -> intHost $(hashQ "Shape")       <> encodeArrayVar a+    ShapeSize _ sh              -> intHost $(hashQ "ShapeSize")   <> travE sh+    Foreign _ _ f e             -> intHost $(hashQ "Foreign")     <> travF f  <> travE e+    Coerce _ tp e               -> intHost $(hashQ "Coerce")      <> encodeScalarType tp <> travE e -      travL :: forall env' aenv' a b. Elt a => PreOpenFun acc (env',a) aenv' b -> Builder-      travL l = encodeTupleType (eltType (undefined::a)) <> encodePreOpenFun travA l-  in-  case fun of-    Body b -> intHost $(hashQ "Body") <> travB b-    Lam l  -> intHost $(hashQ "Lam")  <> travL l+encodeArrayVar :: ArrayVar aenv a -> Builder+encodeArrayVar (Var repr v) = encodeArrayType repr <> encodeIdx v -{-# INLINE encodeTuple #-}-encodeTuple :: EncodeAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Builder-encodeTuple _ NilTup        = intHost $(hashQ "NilTup")-encodeTuple h (SnocTup t e) = intHost $(hashQ "SnocTup") <> encodeTuple h t <> encodePreOpenExp h e+{-# INLINEABLE encodeOpenFun #-}+encodeOpenFun+    :: OpenFun env aenv f+    -> Builder+encodeOpenFun (Body b)    = intHost $(hashQ "Body") <> encodeOpenExp b+encodeOpenFun (Lam lhs l) = intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> encodeOpenFun l  -{-# INLINE encodeConst #-}-encodeConst :: TupleType t -> t -> Builder-encodeConst TypeRunit         ()    = mempty-encodeConst (TypeRscalar t)   c     = encodeScalarConst t c-encodeConst (TypeRpair ta tb) (a,b) = encodeConst ta a <> encodeConst tb b+encodeConst :: TypeR t -> t -> Builder+encodeConst TupRunit         ()    = intHost $(hashQ "nil")+encodeConst (TupRsingle t)   c     = encodeScalarConst t c+encodeConst (TupRpair ta tb) (a,b) = intHost $(hashQ "pair") <> encodeConst ta a <> encodeConst tb b -{-# INLINE encodeScalarConst #-} encodeScalarConst :: ScalarType t -> t -> Builder encodeScalarConst (SingleScalarType t) = encodeSingleConst t encodeScalarConst (VectorScalarType t) = encodeVectorConst t -{-# INLINE encodeSingleConst #-} encodeSingleConst :: SingleType t -> t -> Builder-encodeSingleConst (NumSingleType t)    = encodeNumConst t-encodeSingleConst (NonNumSingleType t) = encodeNonNumConst t--{-# INLINE encodeVectorConst #-}-encodeVectorConst :: VectorType t -> t -> Builder-encodeVectorConst (Vector2Type t) (V2 a b)     = intHost $(hashQ "V2") <> encodeSingleConst t a <> encodeSingleConst t b-encodeVectorConst (Vector3Type t) (V3 a b c)   = intHost $(hashQ "V3") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c-encodeVectorConst (Vector4Type t) (V4 a b c d) = intHost $(hashQ "V4") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d-encodeVectorConst (Vector8Type t) (V8 a b c d e f g h) =-  intHost $(hashQ "V8") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d-                        <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h-encodeVectorConst (Vector16Type t) (V16 a b c d e f g h i j k l m n o p) =-  intHost $(hashQ "V16") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d-                         <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h-                         <> encodeSingleConst t i <> encodeSingleConst t j <> encodeSingleConst t k <> encodeSingleConst t l-                         <> encodeSingleConst t m <> encodeSingleConst t n <> encodeSingleConst t o <> encodeSingleConst t p--{-# INLINE encodeNonNumConst #-}-encodeNonNumConst :: NonNumType t -> t -> Builder-encodeNonNumConst TypeBool{}   x          = intHost $(hashQ "Bool")   <> word8 (fromBool x)-encodeNonNumConst TypeChar{}   x          = intHost $(hashQ "Char")   <> charUtf8 x-encodeNonNumConst TypeCSChar{} (CSChar x) = intHost $(hashQ "CSChar") <> int8 x-encodeNonNumConst TypeCUChar{} (CUChar x) = intHost $(hashQ "CUChar") <> word8 x-encodeNonNumConst TypeCChar{}  (CChar  x) = intHost $(hashQ "CChar")  <> $( case isSigned (undefined::CChar) of-                                                                              True  -> [e| int8  |]-                                                                              False -> [e| word8 |] ) x+encodeSingleConst (NumSingleType t) = encodeNumConst t -{-# INLINE fromBool #-}-fromBool :: Bool -> Word8-fromBool True  = 1-fromBool False = 0+encodeVectorConst :: VectorType (Vec n t) -> Vec n t -> Builder+encodeVectorConst (VectorType n t) (Vec ba#) = intHost $(hashQ "Vec") <> intHost n <> encodeSingleType t <> shortByteString (SBS ba#) -{-# INLINE encodeNumConst #-} encodeNumConst :: NumType t -> t -> Builder encodeNumConst (IntegralNumType t) = encodeIntegralConst t encodeNumConst (FloatingNumType t) = encodeFloatingConst t -{-# INLINE encodeIntegralConst #-} encodeIntegralConst :: IntegralType t -> t -> Builder-encodeIntegralConst TypeInt{}     x           = intHost $(hashQ "Int")     <> intHost x-encodeIntegralConst TypeInt8{}    x           = intHost $(hashQ "Int8")    <> int8 x-encodeIntegralConst TypeInt16{}   x           = intHost $(hashQ "Int16")   <> int16Host x-encodeIntegralConst TypeInt32{}   x           = intHost $(hashQ "Int32")   <> int32Host x-encodeIntegralConst TypeInt64{}   x           = intHost $(hashQ "Int64")   <> int64Host x-encodeIntegralConst TypeWord{}    x           = intHost $(hashQ "Word")    <> wordHost x-encodeIntegralConst TypeWord8{}   x           = intHost $(hashQ "Word8")   <> word8 x-encodeIntegralConst TypeWord16{}  x           = intHost $(hashQ "Word16")  <> word16Host x-encodeIntegralConst TypeWord32{}  x           = intHost $(hashQ "Word32")  <> word32Host x-encodeIntegralConst TypeWord64{}  x           = intHost $(hashQ "Word64")  <> word64Host x-encodeIntegralConst TypeCShort{}  (CShort x)  = intHost $(hashQ "CShort")  <> int16Host x-encodeIntegralConst TypeCUShort{} (CUShort x) = intHost $(hashQ "CUShort") <> word16Host x-encodeIntegralConst TypeCInt{}    (CInt x)    = intHost $(hashQ "CInt")    <> int32Host x-encodeIntegralConst TypeCUInt{}   (CUInt x)   = intHost $(hashQ "CUInt")   <> word32Host x-encodeIntegralConst TypeCLLong{}  (CLLong x)  = intHost $(hashQ "CLLong")  <> int64Host x-encodeIntegralConst TypeCULLong{} (CULLong x) = intHost $(hashQ "CULLong") <> word64Host x-encodeIntegralConst TypeCLong{}   (CLong x)   = intHost $(hashQ "CLong")   <> $( case finiteBitSize (undefined::CLong) of-                                                                                   32 -> [e| int32Host |]-                                                                                   64 -> [e| int64Host |]-                                                                                   _  -> error "I don't know what architecture I am" ) x-encodeIntegralConst TypeCULong{}  (CULong x)  = intHost $(hashQ "CULong")  <> $( case finiteBitSize (undefined::CULong) of-                                                                                   32 -> [e| word32Host |]-                                                                                   64 -> [e| word64Host |]-                                                                                   _  -> error "I don't know what architecture I am" ) x+encodeIntegralConst TypeInt{}    x = intHost $(hashQ "Int")    <> intHost x+encodeIntegralConst TypeInt8{}   x = intHost $(hashQ "Int8")   <> int8 x+encodeIntegralConst TypeInt16{}  x = intHost $(hashQ "Int16")  <> int16Host x+encodeIntegralConst TypeInt32{}  x = intHost $(hashQ "Int32")  <> int32Host x+encodeIntegralConst TypeInt64{}  x = intHost $(hashQ "Int64")  <> int64Host x+encodeIntegralConst TypeWord{}   x = intHost $(hashQ "Word")   <> wordHost x+encodeIntegralConst TypeWord8{}  x = intHost $(hashQ "Word8")  <> word8 x+encodeIntegralConst TypeWord16{} x = intHost $(hashQ "Word16") <> word16Host x+encodeIntegralConst TypeWord32{} x = intHost $(hashQ "Word32") <> word32Host x+encodeIntegralConst TypeWord64{} x = intHost $(hashQ "Word64") <> word64Host x -{-# INLINE encodeFloatingConst #-} encodeFloatingConst :: FloatingType t -> t -> Builder encodeFloatingConst TypeHalf{}    (Half (CUShort x)) = intHost $(hashQ "Half")    <> word16Host x encodeFloatingConst TypeFloat{}   x                  = intHost $(hashQ "Float")   <> floatHost x encodeFloatingConst TypeDouble{}  x                  = intHost $(hashQ "Double")  <> doubleHost x-encodeFloatingConst TypeCFloat{}  (CFloat x)         = intHost $(hashQ "CFloat")  <> floatHost x-encodeFloatingConst TypeCDouble{} (CDouble x)        = intHost $(hashQ "CDouble") <> doubleHost x -{-# INLINE encodePrimConst #-} encodePrimConst :: PrimConst c -> Builder encodePrimConst (PrimMinBound t)  = intHost $(hashQ "PrimMinBound") <> encodeBoundedType t encodePrimConst (PrimMaxBound t)  = intHost $(hashQ "PrimMaxBound") <> encodeBoundedType t encodePrimConst (PrimPi t)        = intHost $(hashQ "PrimPi")       <> encodeFloatingType t -{-# INLINE encodePrimFun #-} encodePrimFun :: PrimFun f -> Builder encodePrimFun (PrimAdd a)                = intHost $(hashQ "PrimAdd")                <> encodeNumType a encodePrimFun (PrimSub a)                = intHost $(hashQ "PrimSub")                <> encodeNumType a@@ -468,86 +451,54 @@ encodePrimFun PrimLAnd                   = intHost $(hashQ "PrimLAnd") encodePrimFun PrimLOr                    = intHost $(hashQ "PrimLOr") encodePrimFun PrimLNot                   = intHost $(hashQ "PrimLNot")-encodePrimFun PrimOrd                    = intHost $(hashQ "PrimOrd")-encodePrimFun PrimChr                    = intHost $(hashQ "PrimChr")-encodePrimFun PrimBoolToInt              = intHost $(hashQ "PrimBoolToInt")  -{-# INLINE encodeTupleType #-}-encodeTupleType :: TupleType t -> Builder-encodeTupleType TypeRunit       = intHost $(hashQ "TypeRunit")-encodeTupleType (TypeRscalar t) = intHost $(hashQ "TypeRscalar") <> encodeScalarType t-encodeTupleType (TypeRpair a b) = intHost $(hashQ "TypeRpair")   <> encodeTupleType a <> intHost (depthTypeR a)-                                                                 <> encodeTupleType b <> intHost (depthTypeR b)+encodeTypeR :: TypeR t -> Builder+encodeTypeR TupRunit       = intHost $(hashQ "TupRunit")+encodeTypeR (TupRsingle t) = intHost $(hashQ "TupRsingle") <> encodeScalarType t+encodeTypeR (TupRpair a b) = intHost $(hashQ "TupRpair")   <> encodeTypeR a <> intHost (depthTypeR a)+                                                           <> encodeTypeR b <> intHost (depthTypeR b) -{-# INLINE depthTypeR #-}-depthTypeR :: TupleType t -> Int-depthTypeR TypeRunit       = 0-depthTypeR TypeRscalar{}   = 1-depthTypeR (TypeRpair a b) = depthTypeR a + depthTypeR b+depthTypeR :: TypeR t -> Int+depthTypeR TupRunit       = 0+depthTypeR TupRsingle{}   = 1+depthTypeR (TupRpair a b) = depthTypeR a + depthTypeR b -{-# INLINE encodeScalarType #-} encodeScalarType :: ScalarType t -> Builder encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> encodeSingleType t encodeScalarType (VectorScalarType t) = intHost $(hashQ "VectorScalarType") <> encodeVectorType t -{-# INLINE encodeSingleType #-} encodeSingleType :: SingleType t -> Builder-encodeSingleType (NumSingleType t)    = intHost $(hashQ "NumSingleType")    <> encodeNumType t-encodeSingleType (NonNumSingleType t) = intHost $(hashQ "NonNumSingleType") <> encodeNonNumType t+encodeSingleType (NumSingleType t) = intHost $(hashQ "NumSingleType")    <> encodeNumType t -{-# INLINE encodeVectorType #-}-encodeVectorType :: VectorType t -> Builder-encodeVectorType (Vector2Type t)  = intHost $(hashQ "Vector2Type") <> encodeSingleType t-encodeVectorType (Vector3Type t)  = intHost $(hashQ "Vector3Type") <> encodeSingleType t-encodeVectorType (Vector4Type t)  = intHost $(hashQ "Vector4Type") <> encodeSingleType t-encodeVectorType (Vector8Type t)  = intHost $(hashQ "Vector8Type") <> encodeSingleType t-encodeVectorType (Vector16Type t) = intHost $(hashQ "Vector16Type") <> encodeSingleType t+encodeVectorType :: VectorType (Vec n t) -> Builder+encodeVectorType (VectorType n t) = intHost $(hashQ "VectorType") <> intHost n <> encodeSingleType t -{-# INLINE encodeBoundedType #-} encodeBoundedType :: BoundedType t -> Builder encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType") <> encodeIntegralType t-encodeBoundedType (NonNumBoundedType t)   = intHost $(hashQ "NonNumBoundedType")   <> encodeNonNumType t -{-# INLINE encodeNonNumType #-}-encodeNonNumType :: NonNumType t -> Builder-encodeNonNumType TypeBool{}   = intHost $(hashQ "Bool")-encodeNonNumType TypeChar{}   = intHost $(hashQ "Char")-encodeNonNumType TypeCChar{}  = intHost $(hashQ "CChar")-encodeNonNumType TypeCSChar{} = intHost $(hashQ "CSChar")-encodeNonNumType TypeCUChar{} = intHost $(hashQ "CUChar")--{-# INLINE encodeNumType #-} encodeNumType :: NumType t -> Builder encodeNumType (IntegralNumType t) = intHost $(hashQ "IntegralNumType") <> encodeIntegralType t encodeNumType (FloatingNumType t) = intHost $(hashQ "FloatingNumType") <> encodeFloatingType t -{-# INLINE encodeIntegralType #-} encodeIntegralType :: IntegralType t -> Builder-encodeIntegralType TypeInt{}     = intHost $(hashQ "Int")-encodeIntegralType TypeInt8{}    = intHost $(hashQ "Int8")-encodeIntegralType TypeInt16{}   = intHost $(hashQ "Int16")-encodeIntegralType TypeInt32{}   = intHost $(hashQ "Int32")-encodeIntegralType TypeInt64{}   = intHost $(hashQ "Int64")-encodeIntegralType TypeWord{}    = intHost $(hashQ "Word")-encodeIntegralType TypeWord8{}   = intHost $(hashQ "Word8")-encodeIntegralType TypeWord16{}  = intHost $(hashQ "Word16")-encodeIntegralType TypeWord32{}  = intHost $(hashQ "Word32")-encodeIntegralType TypeWord64{}  = intHost $(hashQ "Word64")-encodeIntegralType TypeCShort{}  = intHost $(hashQ "CShort")-encodeIntegralType TypeCUShort{} = intHost $(hashQ "CUShort")-encodeIntegralType TypeCInt{}    = intHost $(hashQ "CInt")-encodeIntegralType TypeCUInt{}   = intHost $(hashQ "CUInt")-encodeIntegralType TypeCLong{}   = intHost $(hashQ "CLong")-encodeIntegralType TypeCULong{}  = intHost $(hashQ "CULong")-encodeIntegralType TypeCLLong{}  = intHost $(hashQ "CLLong")-encodeIntegralType TypeCULLong{} = intHost $(hashQ "CULLong")+encodeIntegralType TypeInt{}    = intHost $(hashQ "Int")+encodeIntegralType TypeInt8{}   = intHost $(hashQ "Int8")+encodeIntegralType TypeInt16{}  = intHost $(hashQ "Int16")+encodeIntegralType TypeInt32{}  = intHost $(hashQ "Int32")+encodeIntegralType TypeInt64{}  = intHost $(hashQ "Int64")+encodeIntegralType TypeWord{}   = intHost $(hashQ "Word")+encodeIntegralType TypeWord8{}  = intHost $(hashQ "Word8")+encodeIntegralType TypeWord16{} = intHost $(hashQ "Word16")+encodeIntegralType TypeWord32{} = intHost $(hashQ "Word32")+encodeIntegralType TypeWord64{} = intHost $(hashQ "Word64") -{-# INLINE encodeFloatingType #-} encodeFloatingType :: FloatingType t -> Builder-encodeFloatingType TypeHalf{}    = intHost $(hashQ "Half")-encodeFloatingType TypeFloat{}   = intHost $(hashQ "Float")-encodeFloatingType TypeDouble{}  = intHost $(hashQ "Double")-encodeFloatingType TypeCFloat{}  = intHost $(hashQ "CFloat")-encodeFloatingType TypeCDouble{} = intHost $(hashQ "CDouble")+encodeFloatingType TypeHalf{}   = intHost $(hashQ "Half")+encodeFloatingType TypeFloat{}  = intHost $(hashQ "Float")+encodeFloatingType TypeDouble{} = intHost $(hashQ "Double")++encodeMaybe :: (a -> Builder) -> Maybe a -> Builder+encodeMaybe _ Nothing  = intHost $(hashQ "Nothing")+encodeMaybe f (Just x) = intHost $(hashQ "Just") <> f x 

@@ -1,9 +1,9 @@ -- | -- Module      : Data.Array.Accelerate.Analysis.Hash.TH--- Copyright   : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright   : [2017..2020] The Accelerate Team -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,15 +1,18 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE PatternGuards       #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeOperators       #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Match--- Copyright   : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright   : [2012..2020] The Accelerate Team -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -21,32 +24,39 @@   (:~:)(..),   matchPreOpenAcc,   matchPreOpenAfun,-  matchPreOpenExp,-  matchPreOpenFun,+  matchOpenExp,+  matchOpenFun,   matchPrimFun,  matchPrimFun',    -- auxiliary-  matchIdx, matchTupleType,-  matchIntegralType, matchFloatingType, matchNumType, matchScalarType,+  matchIdx, matchVar, matchVars, matchArrayR, matchArraysR, matchTypeR, matchShapeR,+  matchShapeType, matchIntegralType, matchFloatingType, matchNumType, matchScalarType,+  matchLeftHandSide, matchALeftHandSide, matchELeftHandSide, matchSingleType, matchTupR  ) where --- standard library+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var+import Data.Array.Accelerate.Analysis.Hash+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Slice+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type+import Data.Primitive.Vec+import qualified Data.Array.Accelerate.Sugar.Shape      as Sugar+ import Data.Maybe import Data.Typeable+import Unsafe.Coerce                                    ( unsafeCoerce ) import System.IO.Unsafe                                 ( unsafePerformIO ) import System.Mem.StableName import Prelude                                          hiding ( exp ) --- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Analysis.Hash-import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type - -- The type of matching array computations -- type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :~: t)@@ -57,50 +67,50 @@ -- {-# INLINEABLE matchPreOpenAcc #-} matchPreOpenAcc-    :: forall acc aenv s t.-       MatchAcc  acc-    -> EncodeAcc acc+    :: forall acc aenv s t. HasArraysR acc+    => MatchAcc  acc     -> PreOpenAcc acc aenv s     -> PreOpenAcc acc aenv t     -> Maybe (s :~: t)-matchPreOpenAcc matchAcc encodeAcc = match+matchPreOpenAcc matchAcc = match   where-    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :~: v)-    matchFun = matchPreOpenFun matchAcc encodeAcc+    matchFun :: OpenFun env' aenv' u -> OpenFun env' aenv' v -> Maybe (u :~: v)+    matchFun = matchOpenFun -    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v)-    matchExp = matchPreOpenExp matchAcc encodeAcc+    matchExp :: OpenExp env' aenv' u -> OpenExp env' aenv' v -> Maybe (u :~: v)+    matchExp = matchOpenExp      match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :~: t)-    match (Alet x1 a1) (Alet x2 a2)-      | Just Refl <- matchAcc x1 x2+    match (Alet lhs1 x1 a1) (Alet lhs2 x2 a2)+      | Just Refl <- matchALeftHandSide lhs1 lhs2+      , Just Refl <- matchAcc x1 x2       , Just Refl <- matchAcc a1 a2       = Just Refl      match (Avar v1) (Avar v2)-      = matchIdx v1 v2+      = matchVar v1 v2 -    match (Atuple t1) (Atuple t2)-      | Just Refl <- matchAtuple matchAcc t1 t2-      = gcast Refl  -- surface/representation type+    match (Apair a1 a2) (Apair b1 b2)+      | Just Refl <- matchAcc a1 b1+      , Just Refl <- matchAcc a2 b2+      = Just Refl -    match (Aprj ix1 t1) (Aprj ix2 t2)-      | Just Refl <- matchAcc t1 t2-      , Just Refl <- matchTupleIdx ix1 ix2+    match Anil Anil       = Just Refl -    match (Apply f1 a1) (Apply f2 a2)+    match (Apply _ f1 a1) (Apply _ f2 a2)       | Just Refl <- matchPreOpenAfun matchAcc f1 f2       , Just Refl <- matchAcc                  a1 a2       = Just Refl -    match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2)+    match (Aforeign _ ff1 f1 a1) (Aforeign _ ff2 f2 a2)       | Just Refl <- matchAcc a1 a2       , unsafePerformIO $ do           sn1 <- makeStableName ff1           sn2 <- makeStableName ff2           return $! hashStableName sn1 == hashStableName sn2-      = gcast Refl+      , Just Refl <- matchPreOpenAfun matchAcc f1 f2+      = Just Refl      match (Acond p1 t1 e1) (Acond p2 t2 e2)       | Just Refl <- matchExp p1 p2@@ -114,47 +124,50 @@       , Just Refl <- matchPreOpenAfun matchAcc f1 f2       = Just Refl -    match (Use a1) (Use a2)-      | Just Refl <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2-      = gcast Refl+    match (Use repr1 a1) (Use repr2 a2)+      | Just Refl <- matchArray repr1 repr2 a1 a2+      = Just Refl -    match (Unit e1) (Unit e2)-      | Just Refl <- matchExp e1 e2+    match (Unit t1 e1) (Unit t2 e2)+      | Just Refl <- matchTypeR t1 t2+      , Just Refl <- matchExp e1 e2       = Just Refl -    match (Reshape sh1 a1) (Reshape sh2 a2)+    match (Reshape _ sh1 a1) (Reshape _ sh2 a2)       | Just Refl <- matchExp sh1 sh2       , Just Refl <- matchAcc a1  a2       = Just Refl -    match (Generate sh1 f1) (Generate sh2 f2)+    match (Generate _ sh1 f1) (Generate _ sh2 f2)       | Just Refl <- matchExp sh1 sh2       , Just Refl <- matchFun f1  f2       = Just Refl -    match (Transform sh1 ix1 f1 a1) (Transform sh2 ix2 f2 a2)+    match (Transform _ sh1 ix1 f1 a1) (Transform _ sh2 ix2 f2 a2)       | Just Refl <- matchExp sh1 sh2       , Just Refl <- matchFun ix1 ix2       , Just Refl <- matchFun f1  f2       , Just Refl <- matchAcc a1  a2       = Just Refl -    match (Replicate _ ix1 a1) (Replicate _ ix2 a2)-      | Just Refl <- matchExp ix1 ix2+    match (Replicate si1 ix1 a1) (Replicate si2 ix2 a2)+      | Just Refl <- matchSliceIndex si1 si2+      , Just Refl <- matchExp ix1 ix2       , Just Refl <- matchAcc a1  a2-      = gcast Refl  -- slice specification ??+      = Just Refl -    match (Slice _ a1 ix1) (Slice _ a2 ix2)-      | Just Refl <- matchAcc a1  a2+    match (Slice si1 a1 ix1) (Slice si2 a2 ix2)+      | Just Refl <- matchSliceIndex si1 si2+      , Just Refl <- matchAcc a1  a2       , Just Refl <- matchExp ix1 ix2-      = gcast Refl  -- slice specification ??+      = Just Refl -    match (Map f1 a1) (Map f2 a2)+    match (Map _ f1 a1) (Map _ f2 a2)       | Just Refl <- matchFun f1 f2       , Just Refl <- matchAcc a1 a2       = Just Refl -    match (ZipWith f1 a1 b1) (ZipWith f2 a2 b2)+    match (ZipWith _ f1 a1 b1) (ZipWith _ f2 a2 b2)       | Just Refl <- matchFun f1 f2       , Just Refl <- matchAcc a1 a2       , Just Refl <- matchAcc b1 b2@@ -162,62 +175,31 @@      match (Fold f1 z1 a1) (Fold f2 z2 a2)       | Just Refl <- matchFun f1 f2-      , Just Refl <- matchExp z1 z2-      , Just Refl <- matchAcc a1 a2-      = Just Refl--    match (Fold1 f1 a1) (Fold1 f2 a2)-      | Just Refl <- matchFun f1 f2+      , matchMaybe matchExp z1 z2       , Just Refl <- matchAcc a1 a2       = Just Refl -    match (FoldSeg f1 z1 a1 s1) (FoldSeg f2 z2 a2 s2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchExp z1 z2-      , Just Refl <- matchAcc a1 a2-      , Just Refl <- matchAcc s1 s2-      = Just Refl--    match (Fold1Seg f1 a1 s1) (Fold1Seg f2 a2 s2)+    match (FoldSeg _ f1 z1 a1 s1) (FoldSeg _ f2 z2 a2 s2)       | Just Refl <- matchFun f1 f2+      , matchMaybe matchExp z1 z2       , Just Refl <- matchAcc a1 a2       , Just Refl <- matchAcc s1 s2       = Just Refl -    match (Scanl f1 z1 a1) (Scanl f2 z2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchExp z1 z2-      , Just Refl <- matchAcc a1 a2-      = Just Refl--    match (Scanl' f1 z1 a1) (Scanl' f2 z2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchExp z1 z2-      , Just Refl <- matchAcc a1 a2-      = Just Refl--    match (Scanl1 f1 a1) (Scanl1 f2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchAcc a1 a2-      = Just Refl--    match (Scanr f1 z1 a1) (Scanr f2 z2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchExp z1 z2+    match (Scan d1 f1 z1 a1) (Scan d2 f2 z2 a2)+      | d1 == d2+      , Just Refl <- matchFun f1 f2+      , matchMaybe matchExp z1 z2       , Just Refl <- matchAcc a1 a2       = Just Refl -    match (Scanr' f1 z1 a1) (Scanr' f2 z2 a2)-      | Just Refl <- matchFun f1 f2+    match (Scan' d1 f1 z1 a1) (Scan' d2 f2 z2 a2)+      | d1 == d2+      , Just Refl <- matchFun f1 f2       , Just Refl <- matchExp z1 z2       , Just Refl <- matchAcc a1 a2       = Just Refl -    match (Scanr1 f1 a1) (Scanr1 f2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchAcc a1 a2-      = Just Refl-     match (Permute f1 d1 p1 a1) (Permute f2 d2 p2 a2)       | Just Refl <- matchFun f1 f2       , Just Refl <- matchAcc d1 d2@@ -225,24 +207,24 @@       , Just Refl <- matchAcc a1 a2       = Just Refl -    match (Backpermute sh1 ix1 a1) (Backpermute sh2 ix2 a2)+    match (Backpermute _ sh1 ix1 a1) (Backpermute _ sh2 ix2 a2)       | Just Refl <- matchExp sh1 sh2       , Just Refl <- matchFun ix1 ix2       , Just Refl <- matchAcc a1  a2       = Just Refl -    match (Stencil f1 b1 a1) (Stencil f2 b2 a2)+    match (Stencil s1 _ f1 b1 a1) (Stencil _ _ f2 b2 a2)       | Just Refl <- matchFun f1 f2       , Just Refl <- matchAcc a1 a2-      , matchBoundary matchAcc encodeAcc b1 b2+      , matchBoundary (stencilEltR s1) b1 b2       = Just Refl -    match (Stencil2 f1 b1  a1  b2  a2) (Stencil2 f2 b1' a1' b2' a2')+    match (Stencil2 s1 s2 _ f1 b1  a1  b2  a2) (Stencil2 _ _ _ f2 b1' a1' b2' a2')       | Just Refl <- matchFun f1 f2       , Just Refl <- matchAcc a1 a1'       , Just Refl <- matchAcc a2 a2'-      , matchBoundary matchAcc encodeAcc b1 b1'-      , matchBoundary matchAcc encodeAcc b2 b2'+      , matchBoundary (stencilEltR s1) b1 b1'+      , matchBoundary (stencilEltR s2) b2 b2'       = Just Refl      -- match (Collect s1) (Collect s2)@@ -251,24 +233,6 @@     match _ _       = Nothing ---- Array tuples----{-# INLINEABLE matchAtuple #-}-matchAtuple-    :: MatchAcc acc-    -> Atuple (acc aenv) s-    -> Atuple (acc aenv) t-    -> Maybe (s :~: t)-matchAtuple matchAcc (SnocAtup t1 a1) (SnocAtup t2 a2)-  | Just Refl <- matchAtuple matchAcc t1 t2-  , Just Refl <- matchAcc             a1 a2-  = Just Refl--matchAtuple _ NilAtup NilAtup = Just Refl-matchAtuple _ _       _       = Nothing-- -- Array functions -- {-# INLINEABLE matchPreOpenAfun #-}@@ -277,44 +241,72 @@     -> PreOpenAfun acc aenv s     -> PreOpenAfun acc aenv t     -> Maybe (s :~: t)-matchPreOpenAfun m (Alam s) (Alam t)-  | Just Refl <- matchEnvTop        s t+matchPreOpenAfun m (Alam lhs1 s) (Alam lhs2 t)+  | Just Refl <- matchALeftHandSide lhs1 lhs2   , Just Refl <- matchPreOpenAfun m s t   = Just Refl-  where-    matchEnvTop :: (Arrays s, Arrays t)-                => PreOpenAfun acc (aenv, s) f -> PreOpenAfun acc (aenv, t) g -> Maybe (s :~: t)-    matchEnvTop _ _ = gcast Refl  -- ???  matchPreOpenAfun m (Abody s) (Abody t) = m s t-matchPreOpenAfun _ _         _         = Nothing+matchPreOpenAfun _ _           _           = Nothing +matchALeftHandSide+    :: forall aenv aenv1 aenv2 t1 t2.+       ALeftHandSide t1 aenv aenv1+    -> ALeftHandSide t2 aenv aenv2+    -> Maybe (ALeftHandSide t1 aenv aenv1 :~: ALeftHandSide t2 aenv aenv2)+matchALeftHandSide = matchLeftHandSide matchArrayR +matchELeftHandSide+    :: forall env env1 env2 t1 t2.+       ELeftHandSide t1 env env1+    -> ELeftHandSide t2 env env2+    -> Maybe (ELeftHandSide t1 env env1 :~: ELeftHandSide t2 env env2)+matchELeftHandSide = matchLeftHandSide matchScalarType++matchLeftHandSide+    :: forall s env env1 env2 t1 t2.+      (forall x y. s x -> s y -> Maybe (x :~: y))+    -> LeftHandSide s t1 env env1+    -> LeftHandSide s t2 env env2+    -> Maybe (LeftHandSide s t1 env env1 :~: LeftHandSide s t2 env env2)+matchLeftHandSide f (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2)+  | Just Refl <- matchTupR f repr1 repr2+  = Just Refl+matchLeftHandSide f (LeftHandSideSingle x) (LeftHandSideSingle y)+  | Just Refl <- f x y+  = Just Refl+matchLeftHandSide f (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2)+  | Just Refl <- matchLeftHandSide f a1 b1+  , Just Refl <- matchLeftHandSide f a2 b2+  = Just Refl+matchLeftHandSide _ _ _ = Nothing+ -- Match stencil boundaries ---{-# INLINEABLE matchBoundary #-} matchBoundary-    :: forall acc aenv sh t. Elt t-    => MatchAcc  acc-    -> EncodeAcc acc-    -> PreBoundary acc aenv (Array sh t)-    -> PreBoundary acc aenv (Array sh t)+    :: TypeR t+    -> Boundary aenv (Array sh t)+    -> Boundary aenv (Array sh t)     -> Bool-matchBoundary _ _ Clamp        Clamp        = True-matchBoundary _ _ Mirror       Mirror       = True-matchBoundary _ _ Wrap         Wrap         = True-matchBoundary _ _ (Constant s) (Constant t) = matchConst (eltType (undefined::t)) s t-matchBoundary m h (Function f) (Function g)-  | Just Refl <- matchPreOpenFun m h f g+matchBoundary _  Clamp        Clamp        = True+matchBoundary _  Mirror       Mirror       = True+matchBoundary _  Wrap         Wrap         = True+matchBoundary tp (Constant s) (Constant t) = matchConst tp s t+matchBoundary _  (Function f) (Function g)+  | Just Refl <- matchOpenFun f g   = True-matchBoundary _ _ _ _+matchBoundary _ _ _   = False +matchMaybe :: (s1 -> s2 -> Maybe (t1 :~: t2)) -> Maybe s1 -> Maybe s2 -> Bool+matchMaybe _ Nothing  Nothing  = True+matchMaybe f (Just x) (Just y)+  | Just Refl <- f x y         = True+matchMaybe _ _        _        = False  {-- -- Match sequences ---{-# INLINEABLE matchSeq #-} matchSeq     :: forall acc aenv senv s t.        MatchAcc  acc@@ -324,11 +316,11 @@     -> Maybe (s :~: t) matchSeq m h = match   where-    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :~: v)-    matchFun = matchPreOpenFun m h+    matchFun :: OpenFun env' aenv' u -> OpenFun env' aenv' v -> Maybe (u :~: v)+    matchFun = matchOpenFun m h -    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v)-    matchExp = matchPreOpenExp m h+    matchExp :: OpenExp env' aenv' u -> OpenExp env' aenv' v -> Maybe (u :~: v)+    matchExp = matchOpenExp m h      match :: PreOpenSeq acc aenv senv' u -> PreOpenSeq acc aenv senv' v -> Maybe (u :~: v)     match (Producer p1 s1)   (Producer p2 s2)@@ -395,27 +387,40 @@ -- As a convenience, we are just comparing the stable names, but we could also -- walk the structure comparing the underlying ptrsOfArrayData. ---{-# INLINEABLE matchArrays #-}-matchArrays :: ArraysR s -> ArraysR t -> s -> t -> Maybe (s :~: t)-matchArrays ArraysRunit ArraysRunit () ()-  = Just Refl--matchArrays (ArraysRpair a1 b1) (ArraysRpair a2 b2) (arr1,brr1) (arr2,brr2)-  | Just Refl <- matchArrays a1 a2 arr1 arr2-  , Just Refl <- matchArrays b1 b2 brr1 brr2-  = Just Refl--matchArrays ArraysRarray ArraysRarray (Array _ ad1) (Array _ ad2)-  | unsafePerformIO $ do+matchArray :: ArrayR (Array sh1 e1)+           -> ArrayR (Array sh2 e2)+           -> Array sh1 e1+           -> Array sh2 e2+           -> Maybe (Array sh1 e1 :~: Array sh2 e2)+matchArray repr1 repr2 (Array _ ad1) (Array _ ad2)+  | Just Refl <- matchArrayR repr1 repr2+  , unsafePerformIO $ do       sn1 <- makeStableName ad1       sn2 <- makeStableName ad2       return $! hashStableName sn1 == hashStableName sn2-  = gcast Refl+  = Just Refl -matchArrays _ _ _ _+matchArray _ _ _ _   = Nothing +matchTupR :: (forall u1 u2. s u1 -> s u2 -> Maybe (u1 :~: u2)) -> TupR s t1 -> TupR s t2 -> Maybe (t1 :~: t2)+matchTupR _ TupRunit         TupRunit         = Just Refl+matchTupR f (TupRsingle x)   (TupRsingle y)   = f x y+matchTupR f (TupRpair x1 x2) (TupRpair y1 y2)+  | Just Refl <- matchTupR f x1 y1+  , Just Refl <- matchTupR f x2 y2            = Just Refl+matchTupR _ _                _                = Nothing +matchArraysR :: ArraysR s -> ArraysR t -> Maybe (s :~: t)+matchArraysR = matchTupR matchArrayR++matchArrayR :: ArrayR s -> ArrayR t -> Maybe (s :~: t)+matchArrayR (ArrayR shr1 tp1) (ArrayR shr2 tp2)+  | Just Refl <- matchShapeR shr1 shr2+  , Just Refl <- matchTypeR tp1 tp2 = Just Refl+matchArrayR _ _ = Nothing++ -- Compute the congruence of two scalar expressions. Two nodes are congruent if -- either: --@@ -425,208 +430,152 @@ -- The below attempts to use real typed equality, but occasionally still needs -- to use a cast, particularly when we can only match the representation types. ---{-# INLINEABLE matchPreOpenExp #-}-matchPreOpenExp-    :: forall acc env aenv s t.-       MatchAcc  acc-    -> EncodeAcc acc-    -> PreOpenExp acc env aenv s-    -> PreOpenExp acc env aenv t+{-# INLINEABLE matchOpenExp #-}+matchOpenExp+    :: forall env aenv s t.+       OpenExp env aenv s+    -> OpenExp env aenv t     -> Maybe (s :~: t)-matchPreOpenExp matchAcc encodeAcc = match-  where-    match :: forall env' aenv' s' t'.-             PreOpenExp acc env' aenv' s'-          -> PreOpenExp acc env' aenv' t'-          -> Maybe (s' :~: t')-    match (Let x1 e1) (Let x2 e2)-      | Just Refl <- match x1 x2-      , Just Refl <- match e1 e2-      = Just Refl -    match (Var v1) (Var v2)-      = matchIdx v1 v2--    match (Foreign ff1 _ e1) (Foreign ff2 _ e2)-      | Just Refl <- match e1 e2-      , unsafePerformIO $ do-          sn1 <- makeStableName ff1-          sn2 <- makeStableName ff2-          return $! hashStableName sn1 == hashStableName sn2-      = gcast Refl--    match (Const c1) (Const c2)-      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))-      , matchConst (eltType (undefined::s')) c1 c2-      = gcast Refl  -- surface/representation type--    match Undef Undef-      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))-      = gcast Refl--    match (Coerce e1) (Coerce e2)-      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))-      , Just Refl <- match e1 e2-      = gcast Refl--    match (Tuple t1) (Tuple t2)-      | Just Refl <- matchTuple matchAcc encodeAcc t1 t2-      = gcast Refl  -- surface/representation type--    match (Prj ix1 t1) (Prj ix2 t2)-      | Just Refl <- match         t1  t2-      , Just Refl <- matchTupleIdx ix1 ix2-      = Just Refl+matchOpenExp (Let lhs1 x1 e1) (Let lhs2 x2 e2)+  | Just Refl <- matchELeftHandSide lhs1 lhs2+  , Just Refl <- matchOpenExp x1 x2+  , Just Refl <- matchOpenExp e1 e2+  = Just Refl -    match IndexAny IndexAny-      = gcast Refl  -- ???+matchOpenExp (Evar v1) (Evar v2)+  = matchVar v1 v2 -    match IndexNil IndexNil-      = Just Refl+matchOpenExp (Foreign _ ff1 f1 e1) (Foreign _ ff2 f2 e2)+  | Just Refl <- matchOpenExp e1 e2+  , unsafePerformIO $ do+      sn1 <- makeStableName ff1+      sn2 <- makeStableName ff2+      return $! hashStableName sn1 == hashStableName sn2+  , Just Refl <- matchOpenFun f1 f2+  = Just Refl -    match (IndexCons sl1 a1) (IndexCons sl2 a2)-      | Just Refl <- match sl1 sl2-      , Just Refl <- match a1 a2-      = Just Refl+matchOpenExp (Const t1 c1) (Const t2 c2)+  | Just Refl <- matchScalarType t1 t2+  , matchConst (TupRsingle t1) c1 c2+  = Just Refl -    match (IndexHead sl1) (IndexHead sl2)-      | Just Refl <- match sl1 sl2-      = Just Refl+matchOpenExp (Undef t1) (Undef t2) = matchScalarType t1 t2 -    match (IndexTail sl1) (IndexTail sl2)-      | Just Refl <- match sl1 sl2-      = Just Refl+matchOpenExp (Coerce _ t1 e1) (Coerce _ t2 e2)+  | Just Refl <- matchScalarType t1 t2+  , Just Refl <- matchOpenExp e1 e2+  = Just Refl -    match (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2)-      | Just Refl <- match ix1 ix2-      , Just Refl <- match sh1 sh2-      , Just Refl <- matchSliceRestrict sliceIndex1 sliceIndex2-      = gcast Refl  -- SliceIndex representation/surface type+matchOpenExp (Pair a1 b1) (Pair a2 b2)+  | Just Refl <- matchOpenExp a1 a2+  , Just Refl <- matchOpenExp b1 b2+  = Just Refl -    match (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2)-      | Just Refl <- match ix1 ix2-      , Just Refl <- match sl1 sl2-      , Just Refl <- matchSliceExtend sliceIndex1 sliceIndex2-      = gcast Refl  -- SliceIndex representation/surface type+matchOpenExp Nil Nil+  = Just Refl -    match (ToIndex sh1 i1) (ToIndex sh2 i2)-      | Just Refl <- match sh1 sh2-      , Just Refl <- match i1  i2-      = Just Refl+matchOpenExp (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2)+  | Just Refl <- matchOpenExp ix1 ix2+  , Just Refl <- matchOpenExp sh1 sh2+  , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2+  = Just Refl -    match (FromIndex sh1 i1) (FromIndex sh2 i2)-      | Just Refl <- match i1  i2-      , Just Refl <- match sh1 sh2-      = Just Refl+matchOpenExp (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2)+  | Just Refl <- matchOpenExp ix1 ix2+  , Just Refl <- matchOpenExp sl1 sl2+  , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2+  = Just Refl -    match (Cond p1 t1 e1) (Cond p2 t2 e2)-      | Just Refl <- match p1 p2-      , Just Refl <- match t1 t2-      , Just Refl <- match e1 e2-      = Just Refl+matchOpenExp (ToIndex _ sh1 i1) (ToIndex _ sh2 i2)+  | Just Refl <- matchOpenExp sh1 sh2+  , Just Refl <- matchOpenExp i1  i2+  = Just Refl -    match (While p1 f1 x1) (While p2 f2 x2)-      | Just Refl <- match x1 x2-      , Just Refl <- matchPreOpenFun matchAcc encodeAcc p1 p2-      , Just Refl <- matchPreOpenFun matchAcc encodeAcc f1 f2-      = Just Refl+matchOpenExp (FromIndex _ sh1 i1) (FromIndex _ sh2 i2)+  | Just Refl <- matchOpenExp i1  i2+  , Just Refl <- matchOpenExp sh1 sh2+  = Just Refl -    match (PrimConst c1) (PrimConst c2)-      = matchPrimConst c1 c2+matchOpenExp (Cond p1 t1 e1) (Cond p2 t2 e2)+  | Just Refl <- matchOpenExp p1 p2+  , Just Refl <- matchOpenExp t1 t2+  , Just Refl <- matchOpenExp e1 e2+  = Just Refl -    match (PrimApp f1 x1) (PrimApp f2 x2)-      | Just x1'  <- commutes encodeAcc f1 x1-      , Just x2'  <- commutes encodeAcc f2 x2-      , Just Refl <- match        x1' x2'-      , Just Refl <- matchPrimFun f1  f2-      = Just Refl+matchOpenExp (While p1 f1 x1) (While p2 f2 x2)+  | Just Refl <- matchOpenExp x1 x2+  , Just Refl <- matchOpenFun p1 p2+  , Just Refl <- matchOpenFun f1 f2+  = Just Refl -      | Just Refl <- match x1 x2-      , Just Refl <- matchPrimFun f1 f2-      = Just Refl+matchOpenExp (PrimConst c1) (PrimConst c2)+  = matchPrimConst c1 c2 -    match (Index a1 x1) (Index a2 x2)-      | Just Refl <- matchAcc a1 a2     -- should only be array indices-      , Just Refl <- match    x1 x2-      = Just Refl+matchOpenExp (PrimApp f1 x1) (PrimApp f2 x2)+  | Just x1'  <- commutes f1 x1+  , Just x2'  <- commutes f2 x2+  , Just Refl <- matchOpenExp x1' x2'+  , Just Refl <- matchPrimFun f1  f2+  = Just Refl -    match (LinearIndex a1 x1) (LinearIndex a2 x2)-      | Just Refl <- matchAcc a1 a2-      , Just Refl <- match    x1 x2-      = Just Refl+  | Just Refl <- matchOpenExp x1 x2+  , Just Refl <- matchPrimFun f1 f2+  = Just Refl -    match (Shape a1) (Shape a2)-      | Just Refl <- matchAcc a1 a2     -- should only be array indices-      = Just Refl+matchOpenExp (Index a1 x1) (Index a2 x2)+  | Just Refl <- matchVar a1 a2+  , Just Refl <- matchOpenExp x1 x2+  = Just Refl -    match (ShapeSize sh1) (ShapeSize sh2)-      | Just Refl <- match sh1 sh2-      = Just Refl+matchOpenExp (LinearIndex a1 x1) (LinearIndex a2 x2)+  | Just Refl <- matchVar a1 a2+  , Just Refl <- matchOpenExp x1 x2+  = Just Refl -    match (Intersect sa1 sb1) (Intersect sa2 sb2)-      | Just Refl <- match sa1 sa2-      , Just Refl <- match sb1 sb2-      = Just Refl+matchOpenExp (Shape a1) (Shape a2)+  | Just Refl <- matchVar a1 a2+  = Just Refl -    match (Union sa1 sb1) (Union sa2 sb2)-      | Just Refl <- match sa1 sa2-      , Just Refl <- match sb1 sb2-      = Just Refl+matchOpenExp (ShapeSize _ sh1) (ShapeSize _ sh2)+  | Just Refl <- matchOpenExp sh1 sh2+  = Just Refl -    match _ _-      = Nothing+matchOpenExp _ _+  = Nothing   -- Match scalar functions ---{-# INLINEABLE matchPreOpenFun #-}-matchPreOpenFun-    :: MatchAcc  acc-    -> EncodeAcc acc-    -> PreOpenFun acc env aenv s-    -> PreOpenFun acc env aenv t+{-# INLINEABLE matchOpenFun #-}+matchOpenFun+    :: OpenFun env aenv s+    -> OpenFun env aenv t     -> Maybe (s :~: t)-matchPreOpenFun m h (Lam s) (Lam t)-  | Just Refl <- matchEnvTop         s t-  , Just Refl <- matchPreOpenFun m h s t+matchOpenFun (Lam lhs1 s) (Lam lhs2 t)+  | Just Refl <- matchELeftHandSide lhs1 lhs2+  , Just Refl <- matchOpenFun s t   = Just Refl-  where-    matchEnvTop :: (Elt s, Elt t) => PreOpenFun acc (env, s) aenv f -> PreOpenFun acc (env, t) aenv g -> Maybe (s :~: t)-    matchEnvTop _ _ = gcast Refl  -- ??? -matchPreOpenFun m h (Body s) (Body t) = matchPreOpenExp m h s t-matchPreOpenFun _ _ _        _        = Nothing+matchOpenFun (Body s) (Body t) = matchOpenExp s t+matchOpenFun _        _        = Nothing  -- Matching constants ---{-# INLINEABLE matchConst #-}-matchConst :: TupleType a -> a -> a -> Bool-matchConst TypeRunit         ()      ()      = True-matchConst (TypeRscalar ty)  a       b       = evalEq ty (a,b)-matchConst (TypeRpair ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2+matchConst :: TypeR a -> a -> a -> Bool+matchConst TupRunit         ()      ()      = True+matchConst (TupRsingle ty)  a       b       = evalEq ty (a,b)+matchConst (TupRpair ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2  evalEq :: ScalarType a -> (a, a) -> Bool evalEq (SingleScalarType t) = evalEqSingle t evalEq (VectorScalarType t) = evalEqVector t  evalEqSingle :: SingleType a -> (a, a) -> Bool-evalEqSingle (NumSingleType t)                                  = evalEqNum t-evalEqSingle (NonNumSingleType t) | NonNumDict <- nonNumDict t  = uncurry (==)+evalEqSingle (NumSingleType t) = evalEqNum t  evalEqVector :: VectorType a -> (a, a) -> Bool-evalEqVector (Vector2Type t) (V2 a1 b1, V2 a2 b2)             = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2)-evalEqVector (Vector3Type t) (V3 a1 b1 c1, V3 a2 b2 c2)       = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2)-evalEqVector (Vector4Type t) (V4 a1 b1 c1 d1, V4 a2 b2 c2 d2) = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2)-evalEqVector (Vector8Type t) ( V8 a1 b1 c1 d1 e1 f1 g1 h1-                             , V8 a2 b2 c2 d2 e2 f2 g2 h2 ) =-  evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2) &&-  evalEqSingle t (e1,e2) && evalEqSingle t (f1,f2) && evalEqSingle t (g1,g2) && evalEqSingle t (h1,h2)-evalEqVector (Vector16Type t) ( V16 a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1-                              , V16 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 ) =-  evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2) &&-  evalEqSingle t (e1,e2) && evalEqSingle t (f1,f2) && evalEqSingle t (g1,g2) && evalEqSingle t (h1,h2) &&-  evalEqSingle t (i1,i2) && evalEqSingle t (j1,j2) && evalEqSingle t (k1,k2) && evalEqSingle t (l1,l2) &&-  evalEqSingle t (m1,m2) && evalEqSingle t (n1,n2) && evalEqSingle t (o1,o2) && evalEqSingle t (p1,p2)+evalEqVector VectorType{} = uncurry (==)  evalEqNum :: NumType a -> (a, a) -> Bool evalEqNum (IntegralNumType t) | IntegralDict <- integralDict t  = uncurry (==)@@ -641,79 +590,40 @@ matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v matchIdx _           _           = Nothing ---- Tuple projection indices. Given the same tuple expression structure (tup),--- check that the indices project identical elements.----{-# INLINEABLE matchTupleIdx #-}-matchTupleIdx :: TupleIdx tup s -> TupleIdx tup t -> Maybe (s :~: t)-matchTupleIdx ZeroTupIdx     ZeroTupIdx     = Just Refl-matchTupleIdx (SuccTupIdx s) (SuccTupIdx t) = matchTupleIdx s t-matchTupleIdx _              _              = Nothing---- Tuples----{-# INLINEABLE matchTuple #-}-matchTuple-    :: MatchAcc  acc-    -> EncodeAcc acc-    -> Tuple (PreOpenExp acc env aenv) s-    -> Tuple (PreOpenExp acc env aenv) t-    -> Maybe (s :~: t)-matchTuple _ _ NilTup          NilTup           = Just Refl-matchTuple m h (SnocTup t1 e1) (SnocTup t2 e2)-  | Just Refl <- matchTuple      m h t1 t2-  , Just Refl <- matchPreOpenExp m h e1 e2-  = Just Refl+{-# INLINEABLE matchVar #-}+matchVar :: Var s env t1 -> Var s env t2 -> Maybe (t1 :~: t2)+matchVar (Var _ v1) (Var _ v2) = matchIdx v1 v2 -matchTuple _ _ _               _                = Nothing+{-# INLINEABLE matchVars #-}+matchVars :: Vars s env t1 -> Vars s env t2 -> Maybe (t1 :~: t2)+matchVars TupRunit         TupRunit = Just Refl+matchVars (TupRsingle v1) (TupRsingle v2)+  | Just Refl <- matchVar v1 v2 = Just Refl+matchVars (TupRpair v w) (TupRpair x y)+  | Just Refl <- matchVars v x+  , Just Refl <- matchVars w y  = Just Refl+matchVars _ _ = Nothing   -- Slice specifications ---{-# INLINEABLE matchSliceRestrict #-}-matchSliceRestrict-    :: SliceIndex slix s co  sh-    -> SliceIndex slix t co' sh-    -> Maybe (s :~: t)-matchSliceRestrict SliceNil SliceNil-  = Just Refl--matchSliceRestrict (SliceAll   sl1) (SliceAll   sl2)-  | Just Refl <- matchSliceRestrict sl1 sl2-  = Just Refl--matchSliceRestrict (SliceFixed sl1) (SliceFixed sl2)-  | Just Refl <- matchSliceRestrict sl1 sl2-  = Just Refl--matchSliceRestrict _ _-  = Nothing---{-# INLINEABLE matchSliceExtend #-}-matchSliceExtend-    :: SliceIndex slix sl co  s-    -> SliceIndex slix sl co' t-    -> Maybe (s :~: t)-matchSliceExtend SliceNil SliceNil+matchSliceIndex :: SliceIndex slix1 sl1 co1 sh1 -> SliceIndex slix2 sl2 co2 sh2 -> Maybe (SliceIndex slix1 sl1 co1 sh1 :~: SliceIndex slix2 sl2 co2 sh2)+matchSliceIndex SliceNil SliceNil   = Just Refl -matchSliceExtend (SliceAll   sl1) (SliceAll   sl2)-  | Just Refl <- matchSliceExtend sl1 sl2+matchSliceIndex (SliceAll   sl1) (SliceAll   sl2)+  | Just Refl <- matchSliceIndex sl1 sl2   = Just Refl -matchSliceExtend (SliceFixed sl1) (SliceFixed sl2)-  | Just Refl <- matchSliceExtend sl1 sl2+matchSliceIndex (SliceFixed sl1) (SliceFixed sl2)+  | Just Refl <- matchSliceIndex sl1 sl2   = Just Refl -matchSliceExtend _ _+matchSliceIndex _ _   = Nothing - -- Primitive constants and functions ---{-# INLINEABLE matchPrimConst #-} matchPrimConst :: PrimConst s -> PrimConst t -> Maybe (s :~: t) matchPrimConst (PrimMinBound s) (PrimMinBound t) = matchBoundedType s t matchPrimConst (PrimMaxBound s) (PrimMaxBound t) = matchBoundedType s t@@ -724,7 +634,7 @@ -- Covariant function matching -- {-# INLINEABLE matchPrimFun #-}-matchPrimFun :: (Typeable s, Typeable t) => PrimFun (a -> s) -> PrimFun (a -> t) -> Maybe (s :~: t)+matchPrimFun :: PrimFun (a -> s) -> PrimFun (a -> t) -> Maybe (s :~: t) matchPrimFun (PrimAdd _)                (PrimAdd _)                = Just Refl matchPrimFun (PrimSub _)                (PrimSub _)                = Just Refl matchPrimFun (PrimMul _)                (PrimMul _)                = Just Refl@@ -787,9 +697,6 @@ matchPrimFun PrimLAnd                   PrimLAnd                   = Just Refl matchPrimFun PrimLOr                    PrimLOr                    = Just Refl matchPrimFun PrimLNot                   PrimLNot                   = Just Refl-matchPrimFun PrimOrd                    PrimOrd                    = Just Refl-matchPrimFun PrimChr                    PrimChr                    = Just Refl-matchPrimFun PrimBoolToInt              PrimBoolToInt              = Just Refl  matchPrimFun _ _   = Nothing@@ -798,7 +705,7 @@ -- Contravariant function matching -- {-# INLINEABLE matchPrimFun' #-}-matchPrimFun' :: (Typeable s, Typeable t) => PrimFun (s -> a) -> PrimFun (t -> a) -> Maybe (s :~: t)+matchPrimFun' :: PrimFun (s -> a) -> PrimFun (t -> a) -> Maybe (s :~: t) matchPrimFun' (PrimAdd _)                (PrimAdd _)                = Just Refl matchPrimFun' (PrimSub _)                (PrimSub _)                = Just Refl matchPrimFun' (PrimMul _)                (PrimMul _)                = Just Refl@@ -855,9 +762,6 @@ matchPrimFun' PrimLAnd                   PrimLAnd                   = Just Refl matchPrimFun' PrimLOr                    PrimLOr                    = Just Refl matchPrimFun' PrimLNot                   PrimLNot                   = Just Refl-matchPrimFun' PrimOrd                    PrimOrd                    = Just Refl-matchPrimFun' PrimChr                    PrimChr                    = Just Refl-matchPrimFun' PrimBoolToInt              PrimBoolToInt              = Just Refl  matchPrimFun' (PrimLt s) (PrimLt t)   | Just Refl <- matchSingleType s t@@ -889,19 +793,40 @@  -- Match reified types ---{-# INLINEABLE matchTupleType #-}-matchTupleType :: TupleType s -> TupleType t -> Maybe (s :~: t)-matchTupleType TypeRunit         TypeRunit         = Just Refl-matchTupleType (TypeRscalar s)   (TypeRscalar t)   = matchScalarType s t-matchTupleType (TypeRpair s1 s2) (TypeRpair t1 t2)-  | Just Refl <- matchTupleType s1 t1-  , Just Refl <- matchTupleType s2 t2-  = Just Refl+{-# INLINEABLE matchTypeR #-}+matchTypeR :: TypeR s -> TypeR t -> Maybe (s :~: t)+matchTypeR = matchTupR matchScalarType -matchTupleType _ _++-- Match shapes (dimensionality)+--+-- XXX: Matching shapes is sort of a special case because the representation+-- types really are isomorphic to the surface type. However, 'gcast' does not+-- inline here, meaning that it will always do the fingerprint check, even if+-- the dimensions are known statically and thus the check could be elided as+-- a known branch.+--+{-# INLINEABLE matchShapeType #-}+matchShapeType :: forall s t. (Sugar.Shape s, Sugar.Shape t) => Maybe (s :~: t)+matchShapeType+  | Just Refl <- matchShapeR (Sugar.shapeR @s) (Sugar.shapeR @t)+#ifdef ACCELERATE_INTERNAL_CHECKS+  = gcast Refl+#else+  = Just (unsafeCoerce Refl)+#endif+  | otherwise   = Nothing +{-# INLINEABLE matchShapeR #-}+matchShapeR :: forall s t. ShapeR s -> ShapeR t -> Maybe (s :~: t)+matchShapeR ShapeRz ShapeRz = Just Refl+matchShapeR (ShapeRsnoc shr1) (ShapeRsnoc shr2)+  | Just Refl <- matchShapeR shr1 shr2+  = Just Refl+matchShapeR _ _ = Nothing + -- Match reified type dictionaries -- {-# INLINEABLE matchScalarType #-}@@ -912,26 +837,15 @@  {-# INLINEABLE matchSingleType #-} matchSingleType :: SingleType s -> SingleType t -> Maybe (s :~: t)-matchSingleType (NumSingleType s)    (NumSingleType t)    = matchNumType s t-matchSingleType (NonNumSingleType s) (NonNumSingleType t) = matchNonNumType s t-matchSingleType _                    _                    = Nothing+matchSingleType (NumSingleType s) (NumSingleType t) = matchNumType s t  {-# INLINEABLE matchVectorType #-}-matchVectorType :: VectorType s -> VectorType t -> Maybe (s :~: t)-matchVectorType (Vector2Type s) (Vector2Type t)-  | Just Refl <- matchSingleType s t-  = Just Refl-matchVectorType (Vector3Type s) (Vector3Type t)-  | Just Refl <- matchSingleType s t-  = Just Refl-matchVectorType (Vector4Type s) (Vector4Type t)-  | Just Refl <- matchSingleType s t-  = Just Refl-matchVectorType (Vector8Type s) (Vector8Type t)-  | Just Refl <- matchSingleType s t-  = Just Refl-matchVectorType (Vector16Type s) (Vector16Type t)-  | Just Refl <- matchSingleType s t+matchVectorType :: forall m n s t. VectorType (Vec n s) -> VectorType (Vec m t) -> Maybe (Vec n s :~: Vec m t)+matchVectorType (VectorType n s) (VectorType m t)+  | Just Refl <- if n == m+                   then Just (unsafeCoerce Refl :: n :~: m) -- XXX: we don't have an embedded KnownNat constraint, but+                   else Nothing                             -- this implementation is the same as 'GHC.TypeLits.sameNat'+  , Just Refl <- matchSingleType s t   = Just Refl matchVectorType _ _   = Nothing@@ -945,48 +859,27 @@ {-# INLINEABLE matchBoundedType #-} matchBoundedType :: BoundedType s -> BoundedType t -> Maybe (s :~: t) matchBoundedType (IntegralBoundedType s) (IntegralBoundedType t) = matchIntegralType s t-matchBoundedType (NonNumBoundedType s)   (NonNumBoundedType t)   = matchNonNumType s t-matchBoundedType _                       _                       = Nothing  {-# INLINEABLE matchIntegralType #-} matchIntegralType :: IntegralType s -> IntegralType t -> Maybe (s :~: t)-matchIntegralType TypeInt{}     TypeInt{}     = Just Refl-matchIntegralType TypeInt8{}    TypeInt8{}    = Just Refl-matchIntegralType TypeInt16{}   TypeInt16{}   = Just Refl-matchIntegralType TypeInt32{}   TypeInt32{}   = Just Refl-matchIntegralType TypeInt64{}   TypeInt64{}   = Just Refl-matchIntegralType TypeWord{}    TypeWord{}    = Just Refl-matchIntegralType TypeWord8{}   TypeWord8{}   = Just Refl-matchIntegralType TypeWord16{}  TypeWord16{}  = Just Refl-matchIntegralType TypeWord32{}  TypeWord32{}  = Just Refl-matchIntegralType TypeWord64{}  TypeWord64{}  = Just Refl-matchIntegralType TypeCShort{}  TypeCShort{}  = Just Refl-matchIntegralType TypeCUShort{} TypeCUShort{} = Just Refl-matchIntegralType TypeCInt{}    TypeCInt{}    = Just Refl-matchIntegralType TypeCUInt{}   TypeCUInt{}   = Just Refl-matchIntegralType TypeCLong{}   TypeCLong{}   = Just Refl-matchIntegralType TypeCULong{}  TypeCULong{}  = Just Refl-matchIntegralType TypeCLLong{}  TypeCLLong{}  = Just Refl-matchIntegralType TypeCULLong{} TypeCULLong{} = Just Refl-matchIntegralType _             _             = Nothing+matchIntegralType TypeInt    TypeInt    = Just Refl+matchIntegralType TypeInt8   TypeInt8   = Just Refl+matchIntegralType TypeInt16  TypeInt16  = Just Refl+matchIntegralType TypeInt32  TypeInt32  = Just Refl+matchIntegralType TypeInt64  TypeInt64  = Just Refl+matchIntegralType TypeWord   TypeWord   = Just Refl+matchIntegralType TypeWord8  TypeWord8  = Just Refl+matchIntegralType TypeWord16 TypeWord16 = Just Refl+matchIntegralType TypeWord32 TypeWord32 = Just Refl+matchIntegralType TypeWord64 TypeWord64 = Just Refl+matchIntegralType _            _            = Nothing  {-# INLINEABLE matchFloatingType #-} matchFloatingType :: FloatingType s -> FloatingType t -> Maybe (s :~: t)-matchFloatingType TypeHalf{}    TypeHalf{}    = Just Refl-matchFloatingType TypeFloat{}   TypeFloat{}   = Just Refl-matchFloatingType TypeDouble{}  TypeDouble{}  = Just Refl-matchFloatingType TypeCFloat{}  TypeCFloat{}  = Just Refl-matchFloatingType TypeCDouble{} TypeCDouble{} = Just Refl-matchFloatingType _             _             = Nothing--{-# INLINEABLE matchNonNumType #-}-matchNonNumType :: NonNumType s -> NonNumType t -> Maybe (s :~: t)-matchNonNumType TypeBool{}   TypeBool{}   = Just Refl-matchNonNumType TypeChar{}   TypeChar{}   = Just Refl-matchNonNumType TypeCChar{}  TypeCChar{}  = Just Refl-matchNonNumType TypeCSChar{} TypeCSChar{} = Just Refl-matchNonNumType TypeCUChar{} TypeCUChar{} = Just Refl-matchNonNumType _            _            = Nothing+matchFloatingType TypeHalf   TypeHalf   = Just Refl+matchFloatingType TypeFloat  TypeFloat  = Just Refl+matchFloatingType TypeDouble TypeDouble = Just Refl+matchFloatingType _            _            = Nothing   -- Auxiliary@@ -997,12 +890,11 @@ -- commutativity. -- commutes-    :: forall acc env aenv a r.-       EncodeAcc acc-    -> PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> Maybe (PreOpenExp acc env aenv a)-commutes h f x = case f of+    :: forall env aenv a r.+       PrimFun (a -> r)+    -> OpenExp env aenv a+    -> Maybe (OpenExp env aenv a)+commutes f x = case f of   PrimAdd{}     -> Just (swizzle x)   PrimMul{}     -> Just (swizzle x)   PrimBAnd{}    -> Just (swizzle x)@@ -1016,10 +908,10 @@   PrimLOr       -> Just (swizzle x)   _             -> Nothing   where-    swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a')+    swizzle :: OpenExp env aenv (a',a') -> OpenExp env aenv (a',a')     swizzle exp-      | Tuple (NilTup `SnocTup` a `SnocTup` b)  <- exp-      , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a)+      | (a `Pair` b)  <- exp+      , hashOpenExp a > hashOpenExp b = b `Pair` a       --       | otherwise                               = exp