futhark 0.21.1 → 0.21.2

raw patch · 56 files changed

+2432/−2395 lines, 56 filesdep +futhark-manifestPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: futhark-manifest

API changes (from Hackage documentation)

Files

• docs/installation.rst +8/−163
• docs/usage.rst +1/−2
• futhark.cabal +4/−3
• prelude/soacs.fut +10/−2
• rts/c/scheduler.h +6/−2
• src/Futhark/Actions.hs +43/−6
• src/Futhark/Analysis/HORep/SOAC.hs +1/−1
• src/Futhark/Analysis/Interference.hs +27/−3
• src/Futhark/Analysis/LastUse.hs +129/−82
• src/Futhark/Analysis/MemAlias.hs +161/−0
• src/Futhark/CLI/Dev.hs +35/−3
• src/Futhark/CodeGen/Backends/CCUDA.hs +4/−2
• src/Futhark/CodeGen/Backends/COpenCL.hs +4/−2
• src/Futhark/CodeGen/Backends/GenericC.hs +4/−3
• src/Futhark/CodeGen/Backends/GenericC/CLI.hs +1/−1
• src/Futhark/CodeGen/Backends/GenericC/Manifest.hs +0/−163
• src/Futhark/CodeGen/Backends/GenericC/Server.hs +1/−1
• src/Futhark/CodeGen/Backends/MulticoreC.hs +3/−4
• src/Futhark/CodeGen/Backends/MulticoreWASM.hs +7/−2
• src/Futhark/CodeGen/Backends/SequentialC.hs +4/−3
• src/Futhark/CodeGen/Backends/SequentialWASM.hs +3/−2
• src/Futhark/CodeGen/ImpGen.hs +5/−2
• src/Futhark/CodeGen/ImpGen/GPU/Base.hs +4/−4
• src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +87/−77
• src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +54/−53
• src/Futhark/Compiler.hs +1/−1
• src/Futhark/IR/GPU.hs +3/−3
• src/Futhark/IR/GPU/Op.hs +1/−1
• src/Futhark/IR/GPUMem.hs +1/−1
• src/Futhark/IR/MC.hs +1/−1
• src/Futhark/IR/MC/Op.hs +1/−1
• src/Futhark/IR/MCMem.hs +1/−1
• src/Futhark/IR/Mem.hs +1/−1
• src/Futhark/IR/Parse.hs +2/−2
• src/Futhark/IR/Pretty.hs +1/−1
• src/Futhark/IR/Prop/Types.hs +8/−7
• src/Futhark/IR/SOACS.hs +3/−3
• src/Futhark/IR/SOACS/SOAC.hs +11/−9
• src/Futhark/IR/SegOp.hs +26/−15
• src/Futhark/IR/Seq.hs +3/−3
• src/Futhark/IR/SeqMem.hs +1/−1
• src/Futhark/IR/Syntax/Core.hs +6/−7
• src/Futhark/IR/TypeCheck.hs +1534/−0
• src/Futhark/Internalise/Exps.hs +16/−28
• src/Futhark/Optimise/DoubleBuffer.hs +1/−0
• src/Futhark/Optimise/MemoryBlockMerging.hs +25/−68
• src/Futhark/Pass/ExplicitAllocations.hs +56/−61
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +2/−2
• src/Futhark/Passes.hs +0/−1
• src/Futhark/Pipeline.hs +1/−1
• src/Futhark/Transform/FirstOrderTransform.hs +7/−8
• src/Futhark/TypeCheck.hs +0/−1534
• src/Futhark/Util.hs +6/−0
• src/Language/Futhark/Interpreter.hs +69/−37
• src/Language/Futhark/Prop.hs +32/−7
• src/Language/Futhark/TypeChecker/Terms.hs +6/−4

@@ -6,8 +6,8 @@ There are two main ways to install the Futhark compiler: using a precompiled tarball or compiling from source.  Both methods are discussed below.  If you are using Linux, see-:ref:`linux-installation`.  If you are using Windows, make sure to-read :ref:`windows-installation`.  If you are using macOS, read+:ref:`linux-installation`.  If you are using Windows, see read+:ref:`windows-installation`.  If you are using macOS, see :ref:`macos-installation`.  Futhark is also available via `Nix <https://nixos.org/nix/>`_.  If you@@ -118,9 +118,6 @@ **Linux (x86_64)**   `futhark-nightly-linux-x86_64.tar.xz <https://futhark-lang.org/releases/futhark-nightly-linux-x86_64.tar.xz>`_ -**Windows (x86_64)**-  `futhark-nightly-windows-x86_64.zip <https://futhark-lang.org/releases/futhark-nightly-windows-x86_64.zip>`_-   You will still likely need to make a C compiler (such as GCC) available on your own.  .. _`Haskell tool stack`: http://docs.haskellstack.org/@@ -207,165 +204,13 @@ Setting up Futhark on Windows ----------------------------- -The Futhark compiler itself is easily installed on Windows via-``stack`` (see above).  If you are using the default Windows console,-you may need to run ``chcp 65001`` to make Unicode characters show up-correctly.--It takes a little more work to make the OpenCL and PyOpenCL backends-functional.  This guide was last updated on the 5th of May 2016, and-is for computers using 64-bit Windows along with `CUDA 7.5`_ and-Python 2.7 (`Anaconda`_ preferred).--Also `Git for Windows`_ is required for its Linux command line tools.-If you have not marked the option to add them to path, there are-instructions below how to do so. The GUI alternative to ``git``,-`GitHub Desktop`_ is optional and does not come with the required-tools.--.. _`CUDA 7.5`: https://developer.nvidia.com/cuda-downloads-.. _`Anaconda`: https://www.continuum.io/downloads#_windows-.. _`Git for Windows`: https://git-scm.com/download/win-.. _`GitHub Desktop`: https://desktop.github.com/--Setting up Futhark and OpenCL-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--1) Clone the Futhark repository to your hard drive.--2) Install `Stack`_ using the 64-bit installer.  Compile the Futhark-   compiler as described in :ref:`installation`.--3) For editing environment variables it is strongly recommended that-   you install the `Rapid Environment Editor`_--4) For a Futhark compatible C/C++ compiler, that you will also need to-   install pyOpenCL later, install MingWpy. Do this using the ``pip-   install -i https://pypi.anaconda.org/carlkl/simple mingwpy``-   command.--5) Assuming you have the latest Anaconda distribution as your primary-   one, it will get installed to a place such as-   ``C:\Users\UserName\Anaconda2\share\mingwpy``. The pip installation-   will not add its bin or include directories to path.--   To do so, open the Rapid Environment Editor and add-   ``C:\Users\UserName\Anaconda2\share\mingwpy\bin`` to the system-wide-   ``PATH`` variable.--   If you have other MingW or GCC distributions, make sure MingWpy takes-   priority by moving its entry above the other distributions. You can-   also change which Python distribution is the default one using the-   same trick should you need so.--   If have done so correctly, typing ``where gcc`` in the command prompt-   should list the aforementioned MingWpy installation at the top or show-   only it.--   To finish the installation, add the-   ``C:\Users\UserName\Anaconda2\share\mingwpy\include`` to the ``CPATH``-   environment variable (note: *not* ``PATH``). Create the variable if-   necessary.--6) The header files and the .dll for OpenCL that comes with the CUDA-   7.5 distribution also need to be installed into MingWpy.  Go to-   ``C:\Program Files\NVIDIA GPU Computing Toolkit\CUDA\v7.5\include``-   and copy the ``CL`` directory into the MingWpy ``include`` directory.--   Next, go to ``C:\Program Files\NVIDIA Corporation\OpenCL`` and copy-   the ``OpenCL64.dll`` file into the MingWpy ``lib`` directory (it is-   next to ``include``).--   The CUDA distribution also comes with the static ``OpenCL.lib``, but-   trying to use that one instead of the ``OpenCL64.dll`` will cause-   programs compiled with ``futhark opencl`` to crash, so ignore it-   completely.--Now you should be able to compile with ``futhark opencl`` and run-Futhark programs on the GPU.--Congratulations!--.. _`Stack`: http://docs.haskellstack.org/en/stable/install_and_upgrade/#windows-.. _`Rapid Environment Editor`: http://www.rapidee.com/en/about--Setting up PyOpenCL-~~~~~~~~~~~~~~~~~~~--The following instructions are for how to setup the-``futhark-pyopencl`` backend.--First install Mako using ``pip install mako``.--Also install PyPNG using ``pip install pypng`` (not stricly necessary,-but some examples make use of it).--7) Clone the `PyOpenCL repository`_ to your hard drive. Do-   this instead of downloading the zip, as the zip will not contain-   some of the other repositories it links to and you will end up with-   missing header files.--8) If you have ignored the instructions and gotten Python 3.x instead-   2.7, you will have to do some extra work.--   Edit ``.\pyopencl\compyte\ndarray\gen_elemwise.py`` and-   ``.\pyopencl\compyte\ndarray\test_gpu_ndarray.py`` and convert most-   Python 2.x style print statements to Python 3 syntax. Basically wrap-   print arguments in brackets "(..)" and ignore any lines containing-   StringIO ``>>`` operator.--   Otherwise just go to the next point.--9) Go into the repo directory and from the command line execute-   ``python configure.py``.--   Edit ``siteconf.py`` to following::--     CL_TRACE = false-     CL_ENABLE_GL = false-     CL_INC_DIR = ['c:\\Program Files\\NVIDIA GPU Computing Toolkit\\CUDA\\v7.5\\include']-     CL_LIB_DIR = ['C:\\Program Files\\NVIDIA GPU Computing Toolkit\\CUDA\\v7.5\\lib\\x64']-     CL_LIBNAME = ['OpenCL']-     CXXFLAGS = ['-std=c++0x']-     LDFLAGS = []--   Run the following commands::--     > python setup.py build_ext --compiler=mingw32-     > python setup.py install--If everything went in order, pyOpenCL should be installed on your machine now.--10) Lastly, Pygame needs to be installed.  Again, not stricly-    necessary, but some examples make use of it.  To do so on Windows,-    download ``pygame-1.9.2a0-cp27-none-win_amd64.whl`` from `here-    <http://www.lfd.uci.edu/~gohlke/pythonlibs/#pygame>`_. ``cp27``-    means Python 2.7 and ``win_amd64`` means 64-bit Windows.--    Go to the directory you have downloaded the file and execute ``pip-    install pygame-1.9.2a0-cp27-none-win_amd64.whl`` from the command-    line.--Now you should be able to run the `Game of Life`_ example.--11) To run the makefiles, first setup ``make`` by going to the ``bin``-    directory of MingWpy and making a copy of-    ``mingw32-make.exe``. Then simply rename ``mingw32-make –-    Copy.exe`` or similar to ``make.exe``. Now you will be able to run-    the makefiles.--    Also, if you have not selected to add the optional Linux command-    line tools to ``PATH`` during the ``Git for Windows``-    installation, add the ``C:\Program Files\Git\usr\bin`` directory-    to ``PATH`` manually now.--12) This guide has been written off memory, so if you are having-    difficulties - ask on the `issues page`_. There might be errors in-    it.+Due to limited maintenance and testing resources, Futhark is not+directly supported on Windows.  Install `WSL+<https://docs.microsoft.com/en-us/windows/wsl/install>`_ and follow+the Linux instructions above.  The C code generated by the Futhark+compiler should work on Windows. -.. _`PyOpenCL repository`: https://github.com/pyopencl/pyopencl-.. _`Game of Life`: https://github.com/diku-dk/futhark-benchmarks/tree/master/misc/life-.. _`issues page`: https://github.com/diku-dk/futhark/issues+In the future, we may support Windows directly again.  Futhark with Nix ----------------

@@ -227,8 +227,7 @@ On \*nix (including macOS), the `clinfo <https://github.com/Oblomov/clinfo>`_ tool (available in many package managers) can be used to determine which OpenCL platforms and devices-are available on a given system.  On Windows, `CPU-z-<https://www.cpuid.com/softwares/cpu-z.html>`_ can be used.+are available on a given system.  CUDA-specific Options ~~~~~~~~~~~~~~~~~~~~~

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.21.1+version:        0.21.2 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -60,6 +60,7 @@       Futhark.Analysis.HORep.SOAC       Futhark.Analysis.Interference       Futhark.Analysis.LastUse+      Futhark.Analysis.MemAlias       Futhark.Analysis.Metrics       Futhark.Analysis.Metrics.Type       Futhark.Analysis.PrimExp@@ -102,7 +103,6 @@       Futhark.CodeGen.Backends.COpenCL.Boilerplate       Futhark.CodeGen.Backends.GenericC       Futhark.CodeGen.Backends.GenericC.CLI-      Futhark.CodeGen.Backends.GenericC.Manifest       Futhark.CodeGen.Backends.GenericC.Options       Futhark.CodeGen.Backends.GenericC.Server       Futhark.CodeGen.Backends.GenericPython@@ -195,6 +195,7 @@       Futhark.IR.Syntax       Futhark.IR.Syntax.Core       Futhark.IR.Traversals+      Futhark.IR.TypeCheck       Futhark.Internalise       Futhark.Internalise.AccurateSizes       Futhark.Internalise.Bindings@@ -268,7 +269,6 @@       Futhark.Transform.FirstOrderTransform       Futhark.Transform.Rename       Futhark.Transform.Substitute-      Futhark.TypeCheck       Futhark.Util       Futhark.Util.Console       Futhark.Util.IntegralExp@@ -333,6 +333,7 @@     , free >=4.12.4     , futhark-data >= 1.0.3.0     , futhark-server >= 1.1.2.0+    , futhark-manifest >= 1.0.0.0     , githash >=0.1.6.1     , half >= 0.3     , haskeline

@@ -132,8 +132,16 @@ -- -- In practice, the *O(n)* behaviour only occurs if *m* is also very -- large.-def reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a =-  intrinsics.hist (1, dest, f, ne, is, as) :> *[m]a+def reduce_by_index 'a [n] [m] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a =+  intrinsics.hist_1d (1, dest, f, ne, is, as)++-- | As `reduce_by_index`, but with two-dimensional indexes.+def reduce_by_index_2d 'a [n] [m] [k] (dest : *[m][k]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64)) (as : [n]a) : *[m][k]a =+  intrinsics.hist_2d (1, dest, f, ne, is, as)++-- | As `reduce_by_index`, but with three-dimensional indexes.+def reduce_by_index_3d 'a [n] [m] [k] [l] (dest : *[m][k][l]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64,i64)) (as : [n]a) : *[m][k][l]a =+  intrinsics.hist_3d (1, dest, f, ne, is, as)  -- | Inclusive prefix scan.  Has the same caveats with respect to -- associativity and complexity as `reduce`.

@@ -1113,6 +1113,10 @@ }  static int scheduler_destroy(struct scheduler *scheduler) {+  // We assume that this function is called by the thread controlling+  // the first worker, which is why we treat scheduler->workers[0]+  // specially here.+   // First mark them all as dead.   for (int i = 1; i < scheduler->num_threads; i++) {     struct worker *cur_worker = &scheduler->workers[i];@@ -1132,8 +1136,8 @@     CHECK_ERR(pthread_join(scheduler->workers[i].thread, NULL), "pthread_join");   } -  // And then destroy our local queue.-  subtask_queue_destroy(&worker_local->q);+  // And then destroy our own queue.+  subtask_queue_destroy(&scheduler->workers[0].q);    free(scheduler->workers); 

@@ -6,6 +6,9 @@ module Futhark.Actions   ( printAction,     printAliasesAction,+    printLastUseGPU,+    printInterferenceGPU,+    printMemAliasGPU,     callGraphAction,     impCodeGenAction,     kernelImpCodeGenAction,@@ -30,6 +33,9 @@ import qualified Data.Text.IO as T import Futhark.Analysis.Alias import Futhark.Analysis.CallGraph (buildCallGraph)+import qualified Futhark.Analysis.Interference as Interference+import qualified Futhark.Analysis.LastUse as LastUse+import qualified Futhark.Analysis.MemAlias as MemAlias import Futhark.Analysis.Metrics import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL@@ -74,6 +80,33 @@       actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis     } +-- | Print last use information to stdout.+printLastUseGPU :: Action GPUMem+printLastUseGPU =+  Action+    { actionName = "print last use gpu",+      actionDescription = "Print last use information on gpu.",+      actionProcedure = liftIO . putStrLn . pretty . LastUse.analyseGPUMem+    }++-- | Print interference information to stdout.+printInterferenceGPU :: Action GPUMem+printInterferenceGPU =+  Action+    { actionName = "print interference gpu",+      actionDescription = "Print interference information on gpu.",+      actionProcedure = liftIO . putStrLn . pretty . Interference.analyseProgGPU+    }++-- | Print memory alias information to stdout+printMemAliasGPU :: Action GPUMem+printMemAliasGPU =+  Action+    { actionName = "print mem alias gpu",+      actionDescription = "Print memory alias information on gpu.",+      actionProcedure = liftIO . putStrLn . pretty . MemAlias.analyzeGPUMem+    }+ -- | Print call graph to stdout. callGraphAction :: Action SOACS callGraphAction =@@ -176,7 +209,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ SequentialC.compileProg prog+      cprog <- handleWarnings fcfg $ SequentialC.compileProg (T.pack versionString) prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -204,7 +237,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ COpenCL.compileProg prog+      cprog <- handleWarnings fcfg $ COpenCL.compileProg (T.pack versionString) prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -239,7 +272,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ CCUDA.compileProg prog+      cprog <- handleWarnings fcfg $ CCUDA.compileProg (T.pack versionString) prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -271,7 +304,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ MulticoreC.compileProg prog+      cprog <- handleWarnings fcfg $ MulticoreC.compileProg (T.pack versionString) prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -379,7 +412,9 @@     }   where     helper prog = do-      (cprog, jsprog, exps) <- handleWarnings fcfg $ SequentialWASM.compileProg prog+      (cprog, jsprog, exps) <-+        handleWarnings fcfg $+          SequentialWASM.compileProg (T.pack versionString) prog       case mode of         ToLibrary -> do           writeLibs cprog jsprog@@ -411,7 +446,9 @@     }   where     helper prog = do-      (cprog, jsprog, exps) <- handleWarnings fcfg $ MulticoreWASM.compileProg prog+      (cprog, jsprog, exps) <-+        handleWarnings fcfg $+          MulticoreWASM.compileProg (T.pack versionString) prog        case mode of         ToLibrary -> do

@@ -459,7 +459,7 @@   scremaType w form typeOf (Hist _ ops _ _) = do   op <- ops-  map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op)+  map (`arrayOfShape` histShape op) (lambdaReturnType $ histOp op)  -- | The "width" of a SOAC is the expected outer size of its array -- inputs _after_ input-transforms have been carried out.

@@ -3,7 +3,7 @@ {-# LANGUAGE TypeFamilies #-}  -- | Interference analysis for Futhark programs.-module Futhark.Analysis.Interference (Graph, analyseGPU) where+module Futhark.Analysis.Interference (Graph, analyseProgGPU) where  import Control.Monad.Reader import Data.Foldable (toList)@@ -15,6 +15,8 @@ import Data.Set (Set) import qualified Data.Set as S import Futhark.Analysis.LastUse (LastUseMap)+import qualified Futhark.Analysis.LastUse as LastUse+import qualified Futhark.Analysis.MemAlias as MemAlias import Futhark.IR.GPUMem import Futhark.Util (invertMap) @@ -41,8 +43,7 @@ -- combinator function. cartesian :: (Monoid m, Foldable t) => (a -> a -> m) -> t a -> t a -> m cartesian f xs ys =-  [(x, y) | x <- toList xs, y <- toList ys]-    & foldMap (uncurry f)+  foldMap (uncurry f) [(x, y) | x <- toList xs, y <- toList ys]  analyseStm ::   LocalScope GPUMem m =>@@ -215,6 +216,29 @@   m (InUse, LastUsed, Graph VName) analyseLambda lumap inuse (Lambda _ body _) =   analyseBody lumap inuse body++analyseProgGPU :: Prog GPUMem -> Graph VName+analyseProgGPU prog =+  let (lumap, _) = LastUse.analyseGPUMem prog+      graph =+        foldMap+          ( \f ->+              runReader (analyseGPU lumap $ bodyStms $ funDefBody f) $+                scopeOf f+          )+          $ progFuns prog+      graph' = applyAliases (MemAlias.analyzeGPUMem prog) graph+   in graph'++applyAliases :: MemAlias.MemAliases -> Graph VName -> Graph VName+applyAliases aliases =+  -- For each pair @(x, y)@ in graph, all memory aliases of x should interfere with all memory aliases of y+  foldMap+    ( \(x, y) ->+        let xs = MemAlias.aliasesOf aliases x <> oneName x+            ys = MemAlias.aliasesOf aliases y <> oneName y+         in cartesian makeEdge (namesToList xs) (namesToList ys)+    )  -- | Perform interference analysis on the given statements. The result is a -- triple of the names currently in use, names that hit their last use somewhere

@@ -1,9 +1,13 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  -- | Provides last-use analysis for Futhark programs.-module Futhark.Analysis.LastUse (LastUseMap, analyseProg) where+module Futhark.Analysis.LastUse (LastUseMap, analyseGPUMem, analyseSeqMem) where +import Control.Monad.Reader import Data.Bifunctor (first) import Data.Foldable import Data.Function ((&))@@ -13,6 +17,7 @@ import Futhark.Analysis.Alias (aliasAnalysis) import Futhark.IR.Aliases import Futhark.IR.GPUMem+import Futhark.IR.SeqMem  -- | `LastUseMap` tells which names were last used in a given statement. -- Statements are uniquely identified by the `VName` of the first value@@ -27,31 +32,93 @@ -- or otherwise. type Used = Names +type LastUseOp rep =+  VName -> (LastUse, Used) -> Op (Aliases rep) -> LastUseM rep++newtype Env rep = Env {envLastUseOp :: LastUseOp rep}++type LastUseM rep = Reader (Env rep) (LastUse, Used)++analyseGPUMem :: Prog GPUMem -> (LastUseMap, Used)+analyseGPUMem = analyseProg analyseGPUOp++analyseSeqMem :: Prog SeqMem -> (LastUseMap, Used)+analyseSeqMem = analyseProg analyseSeqOp++analyseGPUOp :: LastUseOp GPUMem+analyseGPUOp pat_name (lumap, used) (Alloc se sp) = do+  let nms = (freeIn se <> freeIn sp) `namesSubtract` used+  return (insertNames pat_name nms lumap, used <> nms)+analyseGPUOp pat_name (lumap, used) (Inner (SizeOp sop)) = do+  let nms = freeIn sop `namesSubtract` used+  return (insertNames pat_name nms lumap, used <> nms)+analyseGPUOp _ (lumap, used) (Inner (OtherOp ())) =+  return (lumap, used)+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegMap lvl _ tps body))) = do+  (lumap', used') <- analyseKernelBody (lumap, used) body+  let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'+  return (insertNames pat_name nms lumap', used' <> nms)+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegRed lvl _ binops tps body))) =+  segOpHelper pat_name lumap used lvl binops tps body+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegScan lvl _ binops tps body))) =+  segOpHelper pat_name lumap used lvl binops tps body+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegHist lvl _ binops tps body))) = do+  (lumap', used') <- foldM analyseHistOp (lumap, used) $ reverse binops+  (lumap'', used'') <- analyseKernelBody (lumap', used') body+  let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''+  return (insertNames pat_name nms lumap'', used'' <> nms)++segOpHelper ::+  (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>+  VName ->+  LastUse ->+  Used ->+  SegLevel ->+  [SegBinOp (Aliases rep)] ->+  [Type] ->+  KernelBody (Aliases rep) ->+  LastUseM rep+segOpHelper pat_name lumap used lvl binops tps body = do+  (lumap', used') <- foldM analyseSegBinOp (lumap, used) $ reverse binops+  (lumap'', used'') <- analyseKernelBody (lumap', used') body+  let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''+  return (insertNames pat_name nms lumap'', used'' <> nms)++analyseSeqOp :: LastUseOp SeqMem+analyseSeqOp pat_name (lumap, used) (Alloc se sp) = do+  let nms = (freeIn se <> freeIn sp) `namesSubtract` used+  return (insertNames pat_name nms lumap, used <> nms)+analyseSeqOp _ (lumap, used) (Inner ()) =+  return (lumap, used)+ -- | Analyses a program to return a last-use map, mapping each simple statement -- in the program to the values that were last used within that statement, and -- the set of all `VName` that were used inside.-analyseProg :: Prog GPUMem -> (LastUseMap, Used)-analyseProg prog =-  let consts =-        progConsts prog-          & concatMap (toList . fmap patElemName . patElems . stmPat)-          & namesFromList-      funs = progFuns $ aliasAnalysis prog-      (lus, used) = foldMap (analyseFun mempty consts) funs-   in (flipMap lus, used)+analyseProg :: (CanBeAliased (Op rep), Mem rep inner) => LastUseOp rep -> Prog rep -> (LastUseMap, Used)+analyseProg onOp prog =+  runReader helper (Env onOp)+  where+    helper = do+      let consts =+            progConsts prog+              & concatMap (toList . fmap patElemName . patElems . stmPat)+              & namesFromList+          funs = progFuns $ aliasAnalysis prog+      (lus, used) <- mconcat <$> mapM (analyseFun mempty consts) funs+      return (flipMap lus, used) -analyseFun :: LastUse -> Used -> FunDef (Aliases GPUMem) -> (LastUse, Used)-analyseFun lumap used fun =-  let (lumap', used') = analyseBody lumap used $ funDefBody fun-   in (lumap', used' <> freeIn (funDefParams fun))+analyseFun :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> FunDef (Aliases rep) -> LastUseM rep+analyseFun lumap used fun = do+  (lumap', used') <- analyseBody lumap used $ funDefBody fun+  return (lumap', used' <> freeIn (funDefParams fun)) -analyseStms :: LastUse -> Used -> Stms (Aliases GPUMem) -> (LastUse, Used)-analyseStms lumap used stms = foldr analyseStm (lumap, used) $ stmsToList stms+analyseStms :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Stms (Aliases rep) -> LastUseM rep+analyseStms lumap used stms = foldM analyseStm (lumap, used) $ reverse $ stmsToList stms -analyseStm :: Stm (Aliases GPUMem) -> (LastUse, Used) -> (LastUse, Used)-analyseStm (Let pat _ e) (lumap0, used0) =+analyseStm :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Stm (Aliases rep) -> LastUseM rep+analyseStm (lumap0, used0) (Let pat _ e) = do   let (lumap', used') = patElems pat & foldl helper (lumap0, used0)-   in analyseExp (lumap', used') e+  analyseExp (lumap', used') e   where     helper (lumap_acc, used_acc) (PatElem name (aliases, _)) =       -- Any aliases of `name` should have the same last-use as `name`@@ -63,92 +130,72 @@       )      pat_name = patElemName $ head $ patElems pat-    analyseExp :: (LastUse, Used) -> Exp (Aliases GPUMem) -> (LastUse, Used)-    analyseExp (lumap, used) (BasicOp _) =++    analyseExp (lumap, used) (BasicOp _) = do       let nms = freeIn e `namesSubtract` used-       in (insertNames pat_name nms lumap, used <> nms)-    analyseExp (lumap, used) (Apply _ args _ _) =+      return (insertNames pat_name nms lumap, used <> nms)+    analyseExp (lumap, used) (Apply _ args _ _) = do       let nms = freeIn $ map fst args-       in (insertNames pat_name nms lumap, used <> nms)-    analyseExp (lumap, used) (If cse then_body else_body dec) =-      let (lumap_then, used_then) = analyseBody lumap used then_body-          (lumap_else, used_else) = analyseBody lumap used else_body-          used' = used_then <> used_else-          nms = ((freeIn cse <> freeIn dec) `namesSubtract` used')-       in (insertNames pat_name nms (lumap_then <> lumap_else), used' <> nms)-    analyseExp (lumap, used) (DoLoop merge form body) =-      let (lumap', used') = analyseBody lumap used body-          nms = (freeIn merge <> freeIn form) `namesSubtract` used'-       in (insertNames pat_name nms lumap', used' <> nms)-    analyseExp (lumap, used) (Op (Alloc se sp)) =-      let nms = (freeIn se <> freeIn sp) `namesSubtract` used-       in (insertNames pat_name nms lumap, used <> nms)-    analyseExp (lumap, used) (Op (Inner (SizeOp sop))) =-      let nms = freeIn sop `namesSubtract` used-       in (insertNames pat_name nms lumap, used <> nms)-    analyseExp (lumap, used) (Op (Inner (OtherOp ()))) =-      (lumap, used)-    analyseExp (lumap, used) (Op (Inner (SegOp (SegMap lvl _ tps body)))) =-      let (lumap', used') = analyseKernelBody (lumap, used) body-          nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'-       in (insertNames pat_name nms lumap', used' <> nms)-    analyseExp (lumap, used) (Op (Inner (SegOp (SegRed lvl _ binops tps body)))) =-      segOpHelper lumap used lvl binops tps body-    analyseExp (lumap, used) (Op (Inner (SegOp (SegScan lvl _ binops tps body)))) =-      segOpHelper lumap used lvl binops tps body-    analyseExp (lumap, used) (Op (Inner (SegOp (SegHist lvl _ binops tps body)))) =-      let (lumap', used') = foldr analyseHistOp (lumap, used) binops-          (lumap'', used'') = analyseKernelBody (lumap', used') body-          nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''-       in (insertNames pat_name nms lumap'', used'' <> nms)+      return (insertNames pat_name nms lumap, used <> nms)+    analyseExp (lumap, used) (If cse then_body else_body dec) = do+      (lumap_then, used_then) <- analyseBody lumap used then_body+      (lumap_else, used_else) <- analyseBody lumap used else_body+      let used' = used_then <> used_else+          nms = (freeIn cse <> freeIn dec) `namesSubtract` used'+      return (insertNames pat_name nms (lumap_then <> lumap_else), used' <> nms)+    analyseExp (lumap, used) (DoLoop merge form body) = do+      (lumap', used') <- analyseBody lumap used body+      let nms = (freeIn merge <> freeIn form) `namesSubtract` used'+      return (insertNames pat_name nms lumap', used' <> nms)+    analyseExp (lumap, used) (Op op) = do+      onOp <- asks envLastUseOp+      onOp pat_name (lumap, used) op     analyseExp (lumap, used) (WithAcc _ l) =       analyseLambda (lumap, used) l-    segOpHelper lumap used lvl binops tps body =-      let (lumap', used') = foldr analyseSegBinOp (lumap, used) binops-          (lumap'', used'') = analyseKernelBody (lumap', used') body-          nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''-       in (insertNames pat_name nms lumap'', used'' <> nms) -analyseBody :: LastUse -> Used -> Body (Aliases GPUMem) -> (LastUse, Used)-analyseBody lumap used (Body _ stms result) =+analyseBody :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Body (Aliases rep) -> LastUseM rep+analyseBody lumap used (Body _ stms result) = do   let used' = used <> freeIn result-   in analyseStms lumap used' stms+  analyseStms lumap used' stms  analyseKernelBody ::+  (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>   (LastUse, Used) ->-  KernelBody (Aliases GPUMem) ->-  (LastUse, Used)+  KernelBody (Aliases rep) ->+  LastUseM rep analyseKernelBody (lumap, used) (KernelBody _ stms result) =   let used' = used <> freeIn result    in analyseStms lumap used' stms  analyseSegBinOp ::-  SegBinOp (Aliases GPUMem) ->+  (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>   (LastUse, Used) ->-  (LastUse, Used)-analyseSegBinOp (SegBinOp _ lambda neutral shp) (lumap, used) =-  let (lumap', used') = analyseLambda (lumap, used) lambda-      nms = (freeIn neutral <> freeIn shp) `namesSubtract` used'-   in (lumap', used' <> nms)+  SegBinOp (Aliases rep) ->+  LastUseM rep+analyseSegBinOp (lumap, used) (SegBinOp _ lambda neutral shp) = do+  (lumap', used') <- analyseLambda (lumap, used) lambda+  let nms = (freeIn neutral <> freeIn shp) `namesSubtract` used'+  return (lumap', used' <> nms)  analyseHistOp ::-  HistOp (Aliases GPUMem) ->+  (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>   (LastUse, Used) ->-  (LastUse, Used)-analyseHistOp (HistOp width race dest neutral shp lambda) (lumap, used) =-  let (lumap', used') = analyseLambda (lumap, used) lambda-      nms =+  HistOp (Aliases rep) ->+  LastUseM rep+analyseHistOp (lumap, used) (HistOp width race dest neutral shp lambda) = do+  (lumap', used') <- analyseLambda (lumap, used) lambda+  let nms =         ( freeIn width <> freeIn race <> freeIn dest <> freeIn neutral             <> freeIn shp         )           `namesSubtract` used'-   in (lumap', used' <> nms)+  return (lumap', used' <> nms) -analyseLambda :: (LastUse, Used) -> Lambda (Aliases GPUMem) -> (LastUse, Used)-analyseLambda (lumap, used) (Lambda params body ret) =-  let (lumap', used') = analyseBody lumap used body-      used'' = used' <> freeIn params <> freeIn ret-   in (lumap', used'')+analyseLambda :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Lambda (Aliases rep) -> LastUseM rep+analyseLambda (lumap, used) (Lambda params body ret) = do+  (lumap', used') <- analyseBody lumap used body+  let used'' = used' <> freeIn params <> freeIn ret+  return (lumap', used'')  flipMap :: Map VName VName -> Map VName Names flipMap m =

@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Futhark.Analysis.MemAlias+  ( analyzeSeqMem,+    analyzeGPUMem,+    canBeSameMemory,+    aliasesOf,+    MemAliases,+  )+where++import Control.Monad.Reader+import Data.Bifunctor+import Data.Function ((&))+import Data.Functor ((<&>))+import qualified Data.Map as M+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Set as S+import Futhark.IR.GPUMem+import Futhark.IR.SeqMem+import Futhark.Util+import Futhark.Util.Pretty++-- For our purposes, memory aliases are a bijective function: If @a@ aliases+-- @b@, @b@ also aliases @a@. However, this relationship is not transitive. Consider for instance the following:+--+-- @+--   let xs@mem_1 =+--     if ... then+--       replicate i 0 @ mem_2+--     else+--       replicate j 1 @ mem_3+-- @+--+-- Here, @mem_1@ aliases both @mem_2@ and @mem_3@, each of which alias @mem_1@+-- but not each other.+newtype MemAliases = MemAliases (M.Map VName Names)+  deriving (Show, Eq)++instance Semigroup MemAliases where+  (MemAliases m1) <> (MemAliases m2) = MemAliases $ M.unionWith (<>) m1 m2++instance Monoid MemAliases where+  mempty = MemAliases mempty++instance Pretty MemAliases where+  ppr (MemAliases m) = ppr m++addAlias :: VName -> VName -> MemAliases -> MemAliases+addAlias v1 v2 m =+  m <> singleton v1 (oneName v2) <> singleton v2 mempty++singleton :: VName -> Names -> MemAliases+singleton v ns = MemAliases $ M.singleton v ns++canBeSameMemory :: MemAliases -> VName -> VName -> Bool+canBeSameMemory (MemAliases m) v1 v2 =+  case fmap (v2 `nameIn`) (M.lookup v1 m) of+    Just True -> True+    Just False -> case fmap (v1 `nameIn`) (M.lookup v2 m) of+      Just b -> b+      Nothing -> error $ "VName not found in MemAliases: " <> pretty v2+    Nothing -> error $ "VName not found in MemAliases: " <> pretty v1++aliasesOf :: MemAliases -> VName -> Names+aliasesOf (MemAliases m) v = fromMaybe mempty $ M.lookup v m++isIn :: VName -> MemAliases -> Bool+isIn v (MemAliases m) = v `S.member` M.keysSet m++newtype Env inner = Env {onInner :: MemAliases -> inner -> MemAliasesM inner MemAliases}++type MemAliasesM inner a = Reader (Env inner) a++analyzeHostOp :: MemAliases -> HostOp GPUMem () -> MemAliasesM (HostOp GPUMem ()) MemAliases+analyzeHostOp m (SegOp (SegMap _ _ _ kbody)) =+  analyzeStms (kernelBodyStms kbody) m+analyzeHostOp m (SegOp (SegRed _ _ _ _ kbody)) =+  analyzeStms (kernelBodyStms kbody) m+analyzeHostOp m (SegOp (SegScan _ _ _ _ kbody)) =+  analyzeStms (kernelBodyStms kbody) m+analyzeHostOp m (SegOp (SegHist _ _ _ _ kbody)) =+  analyzeStms (kernelBodyStms kbody) m+analyzeHostOp _ _ = return mempty++analyzeStm :: (Mem rep inner, LetDec rep ~ LetDecMem) => MemAliases -> Stm rep -> MemAliasesM inner MemAliases+analyzeStm m (Let (Pat [PatElem vname _]) _ (Op (Alloc _ _))) =+  return $ m <> singleton vname mempty+analyzeStm m (Let _ _ (Op (Inner inner))) = do+  on_inner <- asks onInner+  on_inner m inner+analyzeStm m (Let pat _ (If _ then_body else_body _)) = do+  m' <-+    analyzeStms (bodyStms then_body) m+      >>= analyzeStms (bodyStms else_body)+  zip (patNames pat) (map resSubExp $ bodyResult then_body)+    <> zip (patNames pat) (map resSubExp $ bodyResult else_body)+    & mapMaybe (filterFun m')+    & foldr (uncurry addAlias) m'+    & return+analyzeStm m (Let pat _ (DoLoop params _ body)) = do+  let m_init =+        map snd params+          & zip (patNames pat)+          & mapMaybe (filterFun m)+          & foldr (uncurry addAlias) m+      m_params =+        mapMaybe (filterFun m_init . first paramName) params+          & foldr (uncurry addAlias) m_init+  m_body <- analyzeStms (bodyStms body) m_params+  zip (patNames pat) (map resSubExp $ bodyResult body)+    & mapMaybe (filterFun m_body)+    & foldr (uncurry addAlias) m_body+    & return+analyzeStm m _ = return m++filterFun :: MemAliases -> (VName, SubExp) -> Maybe (VName, VName)+filterFun m' (v, Var v') | v' `isIn` m' = Just (v, v')+filterFun _ _ = Nothing++analyzeStms :: (Mem rep inner, LetDec rep ~ LetDecMem) => Stms rep -> MemAliases -> MemAliasesM inner MemAliases+analyzeStms =+  flip $ foldM analyzeStm++analyzeFun :: (Mem rep inner, LetDec rep ~ LetDecMem) => FunDef rep -> MemAliasesM inner MemAliases+analyzeFun f =+  funDefParams f+    & mapMaybe justMem+    & mconcat+    & analyzeStms (bodyStms $ funDefBody f)+  where+    justMem (Param _ v (MemMem _)) = Just $ singleton v mempty+    justMem _ = Nothing++transitiveClosure :: MemAliases -> MemAliases+transitiveClosure ma@(MemAliases m) =+  M.foldMapWithKey+    ( \k ns ->+        namesToList ns+          & foldMap (aliasesOf ma)+          & singleton k+    )+    m+    <> ma++analyzeSeqMem :: Prog SeqMem -> MemAliases+analyzeSeqMem prog = completeBijection $ runReader (analyze prog) $ Env $ \x _ -> return x++analyzeGPUMem :: Prog GPUMem -> MemAliases+analyzeGPUMem prog = completeBijection $ runReader (analyze prog) $ Env analyzeHostOp++analyze :: (Mem rep inner, LetDec rep ~ LetDecMem) => Prog rep -> MemAliasesM inner MemAliases+analyze prog =+  progFuns prog+    & foldM (\m f -> (<>) m <$> analyzeFun f) (MemAliases mempty)+    <&> fixPoint transitiveClosure++completeBijection :: MemAliases -> MemAliases+completeBijection ma@(MemAliases m) =+  M.foldMapWithKey (\k ns -> foldMap (`singleton` oneName k) (namesToList ns)) m <> ma

@@ -25,6 +25,7 @@ import qualified Futhark.IR.SOACS as SOACS import qualified Futhark.IR.Seq as Seq import qualified Futhark.IR.SeqMem as SeqMem+import Futhark.IR.TypeCheck (Checkable, checkProg) import Futhark.Internalise.Defunctionalise as Defunctionalise import Futhark.Internalise.Defunctorise as Defunctorise import Futhark.Internalise.LiftLambdas as LiftLambdas@@ -48,7 +49,6 @@ import Futhark.Pass.KernelBabysitting import Futhark.Pass.Simplify import Futhark.Passes-import Futhark.TypeCheck (Checkable, checkProg) import Futhark.Util.Log import Futhark.Util.Options import qualified Futhark.Util.Pretty as PP@@ -121,7 +121,7 @@   representation (Seq _) = "Seq"   representation (GPUMem _) = "GPUMem"   representation (MCMem _) = "MCMem"-  representation (SeqMem _) = "SeqMEm"+  representation (SeqMem _) = "SeqMem"  instance PP.Pretty UntypedPassState where   ppr (SOACS prog) = PP.ppr prog@@ -454,6 +454,30 @@       "Print the resulting IR with aliases.",     Option       []+      ["print-last-use-gpu"]+      ( NoArg $+          Right $ \opts ->+            opts {futharkAction = GPUMemAction $ \_ _ _ -> printLastUseGPU}+      )+      "Print last use information.",+    Option+      []+      ["print-interference-gpu"]+      ( NoArg $+          Right $ \opts ->+            opts {futharkAction = GPUMemAction $ \_ _ _ -> printInterferenceGPU}+      )+      "Print interference information.",+    Option+      []+      ["print-mem-alias-gpu"]+      ( NoArg $+          Right $ \opts ->+            opts {futharkAction = GPUMemAction $ \_ _ _ -> printMemAliasGPU}+      )+      "Print memory alias information.",+    Option+      []       ["call-graph"]       (NoArg $ Right $ \opts -> opts {futharkAction = SOACSAction callGraphAction})       "Print the resulting call graph.",@@ -561,9 +585,17 @@       ["gpu-mem"],     pipelineOption       getSOACSProg+      "Seq"+      Seq+      "Run the sequential CPU compilation pipeline"+      sequentialPipeline+      []+      ["seq"],+    pipelineOption+      getSOACSProg       "SeqMem"       SeqMem-      "Run the sequential CPU compilation pipeline"+      "Run the sequential CPU+memory compilation pipeline"       sequentialCpuPipeline       []       ["seq-mem"],

@@ -14,6 +14,7 @@  import Control.Monad import Data.Maybe (catMaybes)+import qualified Data.Text as T import Futhark.CodeGen.Backends.CCUDA.Boilerplate import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions, sizeLoggingCode) import qualified Futhark.CodeGen.Backends.GenericC as GC@@ -31,8 +32,8 @@ import NeatInterpolation (untrimming)  -- | Compile the program to C with calls to CUDA.-compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)-compileProg prog = do+compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)+compileProg version prog = do   (ws, Program cuda_code cuda_prelude kernels _ sizes failures prog') <-     ImpGen.compileProg prog   let cost_centres =@@ -53,6 +54,7 @@   (ws,)     <$> GC.compileProg       "cuda"+      version       operations       extra       cuda_includes

@@ -15,6 +15,7 @@  import Control.Monad hiding (mapM) import Data.List (intercalate)+import qualified Data.Text as T import Futhark.CodeGen.Backends.COpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.GenericC.Options@@ -32,8 +33,8 @@ import NeatInterpolation (untrimming)  -- | Compile the program to C with calls to OpenCL.-compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)-compileProg prog = do+compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)+compileProg version prog = do   ( ws,     Program       opencl_code@@ -55,6 +56,7 @@   (ws,)     <$> GC.compileProg       "opencl"+      version       operations       ( generateBoilerplate           opencl_code

@@ -92,13 +92,13 @@ import Data.Maybe import qualified Data.Text as T import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs)-import qualified Futhark.CodeGen.Backends.GenericC.Manifest as Manifest import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.GenericC.Server (serverDefs) import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode import Futhark.CodeGen.RTS.C (halfH, lockH, timingH, utilH) import Futhark.IR.Prop (isBuiltInFunction)+import qualified Futhark.Manifest as Manifest import Futhark.MonadFreshNames import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C@@ -1497,6 +1497,7 @@ compileProg ::   MonadFreshNames m =>   T.Text ->+  T.Text ->   Operations op () ->   CompilerM op () () ->   T.Text ->@@ -1504,7 +1505,7 @@   [Option] ->   Definitions op ->   m CParts-compileProg backend ops extra header_extra spaces options prog = do+compileProg backend version ops extra header_extra spaces options prog = do   src <- getNameSource   let ((prototypes, definitions, entry_point_decls, manifest), endstate) =         runCompilerM ops src () compileProg'@@ -1636,7 +1637,7 @@         ( T.unlines $ map prettyText prototypes,           T.unlines $ map (prettyText . funcToDef) functions,           T.unlines $ map prettyText entry_points,-          Manifest.Manifest (M.fromList entry_points_manifest) types backend+          Manifest.Manifest (M.fromList entry_points_manifest) types backend version         )      funcToDef func = C.FuncDef func loc

@@ -15,7 +15,6 @@ import Data.List (unzip5) import qualified Data.Map as M import qualified Data.Text as T-import Futhark.CodeGen.Backends.GenericC.Manifest import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep   ( cproduct,@@ -24,6 +23,7 @@     scalarToPrim,   ) import Futhark.CodeGen.RTS.C (tuningH, valuesH)+import Futhark.Manifest import Futhark.Util.Pretty (pretty, prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C

@@ -1,163 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | C manifest data structure and serialisation to JSON.------ A manifest contains machine-readable information about the API of--- the compiled Futhark program.  Specifically which entry points are--- available, which types are exposed, and what their C names are.-module Futhark.CodeGen.Backends.GenericC.Manifest-  ( Manifest (..),-    Input (..),-    Output (..),-    EntryPoint (..),-    Type (..),-    ArrayOps (..),-    OpaqueOps (..),-    manifestToJSON,-  )-where--import Data.Aeson (ToJSON (..), object)-import qualified Data.Aeson as JSON-import qualified Data.Aeson.Key as JSON-import Data.Aeson.Text (encodeToLazyText)-import Data.Bifunctor (bimap)-import qualified Data.Map as M-import qualified Data.Text as T-import Data.Text.Lazy (toStrict)---- | Manifest info for an entry point parameter.-data Input = Input-  { inputName :: T.Text,-    inputType :: T.Text,-    inputUnique :: Bool-  }-  deriving (Eq, Ord, Show)---- | Manifest info for an entry point return value.-data Output = Output-  { outputType :: T.Text,-    outputUnique :: Bool-  }-  deriving (Eq, Ord, Show)---- | Manifest info for an entry point.-data EntryPoint = EntryPoint-  { entryPointCFun :: T.Text,-    entryPointOutputs :: [Output],-    entryPointInputs :: [Input]-  }-  deriving (Eq, Ord, Show)---- | The names of the C functions implementing the operations on some--- array type.-data ArrayOps = ArrayOps-  { arrayFree :: T.Text,-    arrayShape :: T.Text,-    arrayValues :: T.Text,-    arrayNew :: T.Text-  }-  deriving (Eq, Ord, Show)---- | The names of the C functions implementing the operations on some--- opaque type.-data OpaqueOps = OpaqueOps-  { opaqueFree :: T.Text,-    opaqueStore :: T.Text,-    opaqueRestore :: T.Text-  }-  deriving (Eq, Ord, Show)---- | Manifest info for a non-scalar type.  Scalar types are not part--- of the manifest for a program.-data Type-  = -- | ctype, Futhark elemtype, rank.-    TypeArray T.Text T.Text Int ArrayOps-  | TypeOpaque T.Text OpaqueOps-  deriving (Eq, Ord, Show)---- | A manifest for a compiled program.-data Manifest = Manifest-  { -- | A mapping from Futhark entry points to how they are-    -- represented in C.-    manifestEntryPoints :: M.Map T.Text EntryPoint,-    -- | A mapping from Futhark type name to how they are represented-    -- at the C level.  Should not contain any of the primitive scalar-    -- types.  For array types, these have empty dimensions,-    -- e.g. @[]i32@.-    manifestTypes :: M.Map T.Text Type,-    -- | The compiler backend used to-    -- compile the program, e.g. @c@.-    manifestBackend :: T.Text-  }-  deriving (Eq, Ord, Show)--instance JSON.ToJSON ArrayOps where-  toJSON (ArrayOps free shape values new) =-    object-      [ ("free", toJSON free),-        ("shape", toJSON shape),-        ("values", toJSON values),-        ("new", toJSON new)-      ]--instance JSON.ToJSON OpaqueOps where-  toJSON (OpaqueOps free store restore) =-    object-      [ ("free", toJSON free),-        ("store", toJSON store),-        ("restore", toJSON restore)-      ]--instance JSON.ToJSON Manifest where-  toJSON (Manifest entry_points types backend) =-    object-      [ ("backend", toJSON backend),-        ( "entry_points",-          object $ map (bimap JSON.fromText onEntryPoint) $ M.toList entry_points-        ),-        ( "types",-          object $ map (bimap JSON.fromText onType) $ M.toList types-        )-      ]-    where-      onEntryPoint (EntryPoint cfun outputs inputs) =-        object-          [ ("cfun", toJSON cfun),-            ("outputs", toJSON $ map onOutput outputs),-            ("inputs", toJSON $ map onInput inputs)-          ]--      onOutput (Output t u) =-        object-          [ ("type", toJSON t),-            ("unique", toJSON u)-          ]--      onInput (Input p t u) =-        object-          [ ("name", toJSON p),-            ("type", toJSON t),-            ("unique", toJSON u)-          ]--      onType (TypeArray t et rank ops) =-        object-          [ ("kind", "array"),-            ("ctype", toJSON t),-            ("rank", toJSON rank),-            ("elemtype", toJSON et),-            ("ops", toJSON ops)-          ]-      onType (TypeOpaque t ops) =-        object-          [ ("kind", "opaque"),-            ("ctype", toJSON t),-            ("ops", toJSON ops)-          ]---- | Serialise a manifest in JSON format, so it can be read from other--- tools.  The schema supposed to be at--- https://futhark-lang.org/manifest.schema.json.-manifestToJSON :: Manifest -> T.Text-manifestToJSON = toStrict . encodeToLazyText

@@ -15,10 +15,10 @@ import Data.Bifunctor (first, second) import qualified Data.Map as M import qualified Data.Text as T-import Futhark.CodeGen.Backends.GenericC.Manifest import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH)+import Futhark.Manifest import Futhark.Util (zEncodeString) import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C

@@ -33,13 +33,12 @@  -- | Compile the program to ImpCode with multicore operations. compileProg ::-  MonadFreshNames m =>-  Prog MCMem ->-  m (ImpGen.Warnings, GC.CParts)-compileProg =+  MonadFreshNames m => T.Text -> Prog MCMem -> m (ImpGen.Warnings, GC.CParts)+compileProg version =   traverse     ( GC.compileProg         "multicore"+        version         operations         generateContext         ""

@@ -25,13 +25,18 @@ import Futhark.IR.MCMem import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))-compileProg prog = do+compileProg ::+  MonadFreshNames m =>+  T.Text ->+  Prog MCMem ->+  m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))+compileProg version prog = do   (ws, prog') <- ImpGen.compileProg prog    prog'' <-     GC.compileProg       "wasm_multicore"+      version       MC.operations       MC.generateContext       ""

@@ -13,6 +13,7 @@ where  import Control.Monad+import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.SequentialC.Boilerplate import qualified Futhark.CodeGen.ImpCode.Sequential as Imp@@ -21,10 +22,10 @@ import Futhark.MonadFreshNames  -- | Compile the program to sequential C.-compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, GC.CParts)-compileProg =+compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, GC.CParts)+compileProg version =   traverse-    (GC.compileProg "c" operations generateBoilerplate mempty [DefaultSpace] [])+    (GC.compileProg "c" version operations generateBoilerplate mempty [DefaultSpace] [])     <=< ImpGen.compileProg   where     operations :: GC.Operations Imp.Sequential ()

@@ -26,13 +26,14 @@ import Futhark.MonadFreshNames  -- | Compile the program to sequential C with a JavaScript wrapper.-compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))-compileProg prog = do+compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))+compileProg version prog = do   (ws, prog') <- ImpGen.compileProg prog    prog'' <-     GC.compileProg       "wasm"+      version       operations       generateBoilerplate       ""

@@ -1621,7 +1621,9 @@               pretty name,               "and array-typed source",               pretty src,-              "with slice",+              "of shape",+              pretty (entryArrayShape arr),+              "sliced with",               pretty src_slice             ]     (ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do@@ -1629,7 +1631,8 @@           bt = entryArrayElemType src_arr       emit =<< copyArrayDWIM bt dest_loc dest_slice src_loc src_slice     (ArrayDestination (Just dest_loc), ScalarVar _ (ScalarEntry bt))-      | Just dest_is <- mapM dimFix dest_slice -> do+      | Just dest_is <- mapM dimFix dest_slice,+        length dest_is == length (memLocShape dest_loc) -> do         (dest_mem, dest_space, dest_i) <- fullyIndexArray' dest_loc dest_is         vol <- asks envVolatility         emit $ Imp.Write dest_mem dest_i bt dest_space vol (Imp.var src bt)

@@ -345,7 +345,7 @@           locks <- newVName "locks"            let num_locks = toInt64Exp $ unCount group_size-              dims = map toInt64Exp $ shapeDims (histShape op) ++ [histWidth op]+              dims = map toInt64Exp $ shapeDims (histOpShape op <> histShape op)               l' = Locking locks 0 1 0 (pure . (`rem` num_locks) . flattenIndex dims)               locks_t = Array int32 (Shape [unCount group_size]) NoUniqueness @@ -545,10 +545,10 @@       let vs_per_op = chunks (map (length . histDest) ops) red_vs        forM_ (zip4 red_is vs_per_op ops' ops) $-        \(bin, op_vs, do_op, HistOp dest_w _ _ _ shape lam) -> do+        \(bin, op_vs, do_op, HistOp dest_shape _ _ _ shape lam) -> do           let bin' = toInt64Exp bin-              dest_w' = toInt64Exp dest_w-              bin_in_bounds = 0 .<=. bin' .&&. bin' .<. dest_w'+              dest_shape' = map toInt64Exp $ shapeDims dest_shape+              bin_in_bounds = inBounds (Slice (map DimFix [bin'])) dest_shape'               bin_is = map Imp.le64 (init ltids) ++ [bin']               vs_params = takeLast (length op_vs) $ lambdaParams lam 

@@ -40,7 +40,7 @@ module Futhark.CodeGen.ImpGen.GPU.SegHist (compileSegHist) where  import Control.Monad.Except-import Data.List (foldl', genericLength, zip4, zip6)+import Data.List (foldl', genericLength, zip5) import Data.Maybe import qualified Futhark.CodeGen.ImpCode.GPU as Imp import Futhark.CodeGen.ImpGen@@ -67,20 +67,21 @@     slugAtomicUpdate :: AtomicUpdate GPUMem KernelEnv   } -histoSpaceUsage ::+histSpaceUsage ::   HistOp GPUMem ->   Imp.Count Imp.Bytes (Imp.TExp Int64)-histoSpaceUsage op =-  sum $-    map-      ( typeSize-          . (`arrayOfRow` histWidth op)-          . (`arrayOfShape` histShape op)-      )-      $ lambdaReturnType $ histOp op+histSpaceUsage op =+  sum . map (typeSize . (`arrayOfShape` (histShape op <> histOpShape op))) $+    lambdaReturnType $ histOp op +histSize :: HistOp GPUMem -> Imp.TExp Int64+histSize = product . map toInt64Exp . shapeDims . histShape++histRank :: HistOp GPUMem -> Int+histRank = shapeRank . histShape+ -- | Figure out how much memory is needed per histogram, both--- segmented and unsegmented,, and compute some other auxiliary+-- segmented and unsegmented, and compute some other auxiliary -- information. computeHistoUsage ::   SegSpace ->@@ -115,7 +116,7 @@         subhistos_mem         $ IxFun.iota $ map pe64 $ shapeDims subhistos_shape -    return $+    pure $       SubhistosInfo subhistos $ do         let unitHistoCase =               emit $@@ -142,7 +143,7 @@          sIf (tvExp num_subhistos .==. 1) unitHistoCase multiHistoCase -  let h = histoSpaceUsage op+  let h = histSpaceUsage op       segmented_h = h * product (map (Imp.bytes . toInt64Exp) $ init $ segSpaceDims space)    atomics <- hostAtomics <$> askEnv@@ -180,10 +181,10 @@       let num_locks = 100151           dims =             map toInt64Exp $-              shapeDims (histShape (slugOp slug))-                ++ [ tvSize (slugNumSubhistos slug),-                     histWidth (slugOp slug)-                   ]+              shapeDims (histOpShape (slugOp slug))+                ++ [tvSize (slugNumSubhistos slug)]+                ++ shapeDims (histShape (slugOp slug))+       locks <-         sStaticArray "hist_locks" (Space "device") int32 $           Imp.ArrayZeros num_locks@@ -219,7 +220,7 @@   -- paper.    -- The sum of all Hs.-  hist_H <- dPrimVE "hist_H" $ sum $ map (toInt64Exp . histWidth . slugOp) slugs+  hist_H <- dPrimVE "hist_H" $ sum $ map (histSize . slugOp) slugs    hist_RF <-     dPrimVE "hist_RF" $@@ -305,18 +306,18 @@           sExt32 $             unCount $               sum $-                map (typeSize . (`arrayOfShape` histShape op)) $+                map (typeSize . (`arrayOfShape` histOpShape op)) $                   Prim int32 : lambdaReturnType (histOp op)         _ ->           sExt32 $             unCount $               sum $-                map (typeSize . (`arrayOfShape` histShape op)) $+                map (typeSize . (`arrayOfShape` histOpShape op)) $                   lambdaReturnType (histOp op)      onOp hist_L2 hist_M_min hist_S hist_RACE_exp l slug = do       let SegHistSlug op num_subhistos subhisto_info do_op = slug-          hist_H = toInt64Exp $ histWidth op+          hist_H = histSize op        hist_H_chk <- dPrimVE "hist_H_chk" $ hist_H `divUp` sExt64 hist_S @@ -395,8 +396,8 @@       space_sizes_64 = map (sExt64 . toInt64Exp) space_sizes       total_w_64 = product space_sizes_64 -  hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w ->-    dPrimVE "hist_H_chk" $ toInt64Exp w `divUp` sExt64 hist_S+  hist_H_chks <- forM (map (histSize . slugOp) slugs) $ \w ->+    dPrimVE "hist_H_chk" $ w `divUp` sExt64 hist_S    sKernelThread "seghist_global" num_groups group_size (segFlat space) $ do     constants <- kernelConstants <$> askEnv@@ -437,35 +438,37 @@                 (kernelResultSubExp res)                 [] -          let (buckets, vs) = splitAt (length slugs) red_res-              perOp = chunks $ map (length . histDest . slugOp) slugs+          let red_res_split =+                splitHistResults (map slugOp slugs) $+                  map kernelResultSubExp red_res            sComment "perform atomic updates" $-            forM_ (zip6 (map slugOp slugs) histograms buckets (perOp vs) subhisto_inds hist_H_chks) $-              \( HistOp dest_w _ _ _ shape lam,+            forM_ (zip5 (map slugOp slugs) histograms red_res_split subhisto_inds hist_H_chks) $+              \( HistOp dest_shape _ _ _ shape lam,                  do_op,-                 bucket,-                 vs',+                 (bucket, vs'),                  subhisto_ind,                  hist_H_chk                  ) -> do                   let chk_beg = sExt64 chk_i * hist_H_chk-                      bucket' = toInt64Exp $ kernelResultSubExp bucket-                      dest_w' = toInt64Exp dest_w+                      bucket' = map toInt64Exp bucket+                      dest_shape' = map toInt64Exp $ shapeDims dest_shape+                      flat_bucket = flattenIndex dest_shape' bucket'                       bucket_in_bounds =-                        chk_beg .<=. bucket'-                          .&&. bucket' .<. (chk_beg + hist_H_chk)-                          .&&. bucket' .<. dest_w'+                        chk_beg .<=. flat_bucket+                          .&&. flat_bucket .<. (chk_beg + hist_H_chk)+                          .&&. inBounds (Slice (map DimFix bucket')) dest_shape'                       vs_params = takeLast (length vs') $ lambdaParams lam                    sWhen bucket_in_bounds $ do                     let bucket_is =                           map Imp.le64 (init space_is)-                            ++ [sExt64 subhisto_ind, bucket']+                            ++ [sExt64 subhisto_ind]+                            ++ unflattenIndex dest_shape' (flat_bucket - chk_beg)                     dLParams $ lambdaParams lam                     sLoopNest shape $ \is -> do                       forM_ (zip vs_params vs') $ \(p, res) ->-                        copyDWIMFix (paramName p) [] (kernelResultSubExp res) is+                        copyDWIMFix (paramName p) [] res is                       do_op (bucket_is ++ is)  histKernelGlobal ::@@ -540,7 +543,7 @@             let lock_shape =                   Shape $                     tvSize num_subhistos_per_group :-                    shapeDims (histShape op)+                    shapeDims (histOpShape op)                       ++ [hist_H_chk]              let dims = map toInt64Exp $ shapeDims lock_shape@@ -560,7 +563,7 @@               forM (histType op) $ \t -> do                 let sub_local_shape =                       Shape [tvSize num_subhistos_per_group]-                        <> (arrayShape t `setOuterDim` hist_H_chk)+                        <> setOuterDims (arrayShape t) (histRank op) (Shape [hist_H_chk])                 sAllocArray                   "subhistogram_local"                   (elemType t)@@ -614,13 +617,13 @@       dPrimVE "num_segments" $         product $ map toInt64Exp segment_dims -    hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w ->-      dPrimV "hist_H_chk" $ toInt64Exp w `divUp` sExt64 hist_S+    hist_H_chks <- forM (map slugOp slugs) $ \op ->+      dPrimV "hist_H_chk" $ histSize op `divUp` sExt64 hist_S      histo_sizes <- forM (zip slugs hist_H_chks) $ \(slug, hist_H_chk) -> do       let histo_dims =             tvExp hist_H_chk :-            map toInt64Exp (shapeDims (histShape (slugOp slug)))+            map toInt64Exp (shapeDims (histOpShape (slugOp slug)))       histo_size <-         dPrimVE "histo_size" $ product histo_dims       let group_hists_size =@@ -683,9 +686,14 @@                        local_subhisto_i <- dPrimVE "local_subhisto_i" $ j `quot` sExt32 histo_size                       let local_bucket_is = unflattenIndex histo_dims $ sExt64 $ j `rem` sExt32 histo_size+                          nested_hist_size =+                            map toInt64Exp $ shapeDims $ histShape $ slugOp slug+                           global_bucket_is =-                            head local_bucket_is + sExt64 chk_i * hist_H_chk :-                            tail local_bucket_is+                            unflattenIndex+                              nested_hist_size+                              (head local_bucket_is + sExt64 chk_i * hist_H_chk)+                              ++ tail local_bucket_is                       global_subhisto_i <- dPrimVE "global_subhisto_i" $ j_offset `quot` sExt32 histo_size                        sWhen (j .<. group_hists_size) $@@ -707,7 +715,7 @@               sIf                 (global_subhisto_i .==. 0)                 (copyDWIMFix dest_local local_is (Var dest_global) global_is)-                ( sLoopNest (histShape op) $ \is ->+                ( sLoopNest (histOpShape op) $ \is ->                     copyDWIMFix dest_local (local_is ++ is) ne []                 ) @@ -724,8 +732,6 @@             let (red_res, map_res) =                   splitFromEnd (length map_pes) $                     map kernelResultSubExp $ kernelBodyResult kbody-                (buckets, vs) = splitAt (length slugs) red_res-                perOp = chunks $ map (length . histDest . slugOp) slugs              sWhen (chk_i .==. 0) $               sComment "save map-out results" $@@ -736,20 +742,22 @@                     se                     [] -            forM_ (zip4 (map slugOp slugs) histograms buckets (perOp vs)) $-              \( HistOp dest_w _ _ _ shape lam,+            let red_res_split = splitHistResults (map slugOp slugs) red_res+            forM_ (zip3 (map slugOp slugs) histograms red_res_split) $+              \( HistOp dest_shape _ _ _ shape lam,                  (_, hist_H_chk, do_op),-                 bucket,-                 vs'+                 (bucket, vs')                  ) -> do                   let chk_beg = sExt64 chk_i * tvExp hist_H_chk-                      bucket' = toInt64Exp bucket-                      dest_w' = toInt64Exp dest_w+                      bucket' = map toInt64Exp bucket+                      dest_shape' = map toInt64Exp $ shapeDims dest_shape+                      flat_bucket = flattenIndex dest_shape' bucket'                       bucket_in_bounds =-                        bucket' .<. dest_w'-                          .&&. chk_beg .<=. bucket'-                          .&&. bucket' .<. (chk_beg + tvExp hist_H_chk)-                      bucket_is = [sExt64 thread_local_subhisto_i, bucket' - chk_beg]+                        inBounds (Slice (map DimFix bucket')) dest_shape'+                          .&&. chk_beg .<=. flat_bucket+                          .&&. flat_bucket .<. (chk_beg + tvExp hist_H_chk)+                      bucket_is =+                        [sExt64 thread_local_subhisto_i, flat_bucket - chk_beg]                       vs_params = takeLast (length vs') $ lambdaParams lam                    sComment "perform atomic updates" $@@ -765,13 +773,11 @@         sComment "Compact the multiple local memory subhistograms to result in global memory" $           onSlugs $ \slug dests hist_H_chk histo_dims _histo_size bins_per_thread -> do             trunc_H <--              dPrimV "trunc_H" $-                sMin64 hist_H_chk $-                  toInt64Exp (histWidth (slugOp slug))-                    - sExt64 chk_i * head histo_dims+              dPrimV "trunc_H" . sMin64 hist_H_chk $+                histSize (slugOp slug) - sExt64 chk_i * head histo_dims             let trunc_histo_dims =                   tvExp trunc_H :-                  map toInt64Exp (shapeDims (histShape (slugOp slug)))+                  map toInt64Exp (shapeDims (histOpShape (slugOp slug)))             trunc_histo_size <- dPrimVE "histo_size" $ sExt32 $ product trunc_histo_dims              sFor "local_i" bins_per_thread $ \i -> do@@ -783,9 +789,13 @@                 -- We are responsible for compacting the flat bin 'j', which                 -- we immediately unflatten.                 let local_bucket_is = unflattenIndex histo_dims $ sExt64 j+                    nested_hist_size =+                      map toInt64Exp $ shapeDims $ histShape $ slugOp slug                     global_bucket_is =-                      head local_bucket_is + sExt64 chk_i * hist_H_chk :-                      tail local_bucket_is+                      unflattenIndex+                        nested_hist_size+                        (head local_bucket_is + sExt64 chk_i * hist_H_chk)+                        ++ tail local_bucket_is                 dLParams $ lambdaParams $ histOp $ slugOp slug                 let (global_dests, local_dests) = unzip dests                     (xparams, yparams) =@@ -1050,7 +1060,7 @@     let hist_B = unCount group_size'      -- Size of a histogram.-    hist_H <- dPrimVE "hist_H" $ sum $ map (toInt64Exp . histWidth) ops+    hist_H <- dPrimVE "hist_H" $ sum $ map histSize ops      -- Size of a single histogram element.  Actually the weighted     -- average of histogram elements in cases where we have more than@@ -1116,13 +1126,11 @@         -- unchanged.  To this, we add two dimensions: one over the number         -- of buckets, and one over the number of subhistograms.  This         -- inner dimension is the one that is collapsed in the reduction.-        let num_buckets = histWidth op--        bucket_id <- newVName "bucket_id"+        bucket_ids <-+          replicateM (shapeRank (histShape op)) (newVName "bucket_id")         subhistogram_id <- newVName "subhistogram_id"         vector_ids <--          mapM (const $ newVName "vector_id") $-            shapeDims $ histShape op+          replicateM (shapeRank (histOpShape op)) (newVName "vector_id")          flat_gtid <- newVName "flat_gtid" @@ -1130,18 +1138,20 @@             segred_space =               SegSpace flat_gtid $                 segment_dims-                  ++ [(bucket_id, num_buckets)]-                  ++ zip vector_ids (shapeDims $ histShape op)+                  ++ zip bucket_ids (shapeDims (histShape op))+                  ++ zip vector_ids (shapeDims $ histOpShape op)                   ++ [(subhistogram_id, Var $ tvVar num_histos)]          let segred_op = SegBinOp Commutative (histOp op) (histNeutral op) mempty         compileSegRed' (Pat red_pes) lvl segred_space [segred_op] $ \red_cont ->-          red_cont $-            flip map subhistos $ \subhisto ->-              ( Var subhisto,-                map Imp.le64 $-                  map fst segment_dims ++ [subhistogram_id, bucket_id] ++ vector_ids-              )+          red_cont . flip map subhistos $ \subhisto ->+            ( Var subhisto,+              map Imp.le64 $+                map fst segment_dims+                  ++ [subhistogram_id]+                  ++ bucket_ids+                  ++ vector_ids+            )    emit $ Imp.DebugPrint "" Nothing   where

@@ -4,7 +4,7 @@ where  import Control.Monad-import Data.List (zip4, zip5)+import Data.List (zip4) import qualified Futhark.CodeGen.ImpCode.Multicore as Imp import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Multicore.Base@@ -33,6 +33,9 @@ segHistOpChunks :: [HistOp rep] -> [a] -> [[a]] segHistOpChunks = chunks . map (length . histNeutral) +histSize :: HistOp MCMem -> Imp.TExp Int64+histSize = product . map toInt64Exp . shapeDims . histShape+ nonsegmentedHist ::   Pat MCMem ->   SegSpace ->@@ -44,7 +47,7 @@   let ns = map snd $ unSegSpace space       ns_64 = map toInt64Exp ns       num_histos' = tvExp num_histos-      hist_width = toInt64Exp $ histWidth $ head histops+      hist_width = histSize $ head histops       use_subhistogram = sExt64 num_histos' * hist_width .<=. product ns_64    histops' <- renameHistOpLambda histops@@ -81,9 +84,7 @@       -- Allocate a static array of locks       -- as in the GPU backend       let num_locks = 100151 -- This number is taken from the GPU backend-          dims =-            map toInt64Exp $-              shapeDims (histShape op) ++ [histWidth op]+          dims = map toInt64Exp $ shapeDims (histOpShape op <> histShape op)       locks <-         sStaticArray "hist_locks" DefaultSpace int32 $           Imp.ArrayZeros num_locks@@ -108,17 +109,17 @@   body <- collect $ do     zipWithM_ dPrimV_ is $ unflattenIndex ns_64 $ tvExp flat_idx     compileStms mempty (kernelBodyStms kbody) $ do-      let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody-          perOp = chunks $ map (length . histDest) histops-          (buckets, vs) = splitAt (length histops) red_res+      let (red_res, map_res) =+            splitFromEnd (length map_pes) $ kernelBodyResult kbody+          red_res_split = splitHistResults histops $ map kernelResultSubExp red_res        let pes_per_op = chunks (map (length . histDest) histops) all_red_pes-      forM_ (zip5 histops (perOp vs) buckets atomicOps pes_per_op) $-        \(HistOp dest_w _ _ _ shape lam, vs', bucket, do_op, dest_res) -> do+      forM_ (zip4 histops red_res_split atomicOps pes_per_op) $+        \(HistOp dest_shape _ _ _ shape lam, (bucket, vs'), do_op, dest_res) -> do           let (_is_params, vs_params) = splitAt (length vs') $ lambdaParams lam-              dest_w' = toInt64Exp dest_w-              bucket' = toInt64Exp $ kernelResultSubExp bucket-              bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'+              dest_shape' = map toInt64Exp $ shapeDims dest_shape+              bucket' = map toInt64Exp bucket+              bucket_in_bounds = inBounds (Slice (map DimFix bucket')) dest_shape'            sComment "save map-out results" $             forM_ (zip map_pes map_res) $ \(pe, res) ->@@ -126,11 +127,11 @@            sComment "perform updates" $             sWhen bucket_in_bounds $ do-              let bucket_is = map Imp.le64 (init is) ++ [bucket']+              let bucket_is = map Imp.le64 (init is) ++ bucket'               dLParams $ lambdaParams lam               sLoopNest shape $ \is' -> do                 forM_ (zip vs_params vs') $ \(p, res) ->-                  copyDWIMFix (paramName p) [] (kernelResultSubExp res) is'+                  copyDWIMFix (paramName p) [] res is'                 do_op (map patElemName dest_res) (bucket_is ++ is')    free_params <- freeParams body (segFlat space : [tvVar flat_idx])@@ -202,9 +203,9 @@         sIf           (tid' .==. 0)           (copyDWIMFix hist [] (Var $ patElemName pe) [])-          ( sFor "i" (toInt64Exp $ histWidth histop) $ \i ->-              sLoopNest (histShape histop) $ \vec_is ->-                copyDWIMFix hist (i : vec_is) ne []+          ( sLoopNest (histShape histop) $ \shape_is ->+              sLoopNest (histOpShape histop) $ \vec_is ->+                copyDWIMFix hist (shape_is <> vec_is) ne []           )        return op_local_subhistograms@@ -213,37 +214,32 @@   body <- collect $ do     zipWithM_ dPrimV_ is $ unflattenIndex ns_64 $ sExt64 flat_idx'     compileStms mempty (kernelBodyStms kbody) $ do-      let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody-          (buckets, vs) = splitAt (length histops) red_res-          perOp = chunks $ map (length . histDest) histops+      let (red_res, map_res) =+            splitFromEnd (length map_pes) $+              map kernelResultSubExp $ kernelBodyResult kbody        sComment "save map-out results" $         forM_ (zip map_pes map_res) $ \(pe, res) ->-          copyDWIMFix-            (patElemName pe)-            (map Imp.le64 is)-            (kernelResultSubExp res)-            []+          copyDWIMFix (patElemName pe) (map Imp.le64 is) res [] -      forM_ (zip4 histops local_subhistograms buckets (perOp vs)) $-        \( histop@(HistOp dest_w _ _ _ shape lam),+      forM_ (zip3 histops local_subhistograms (splitHistResults histops red_res)) $+        \( histop@(HistOp dest_shape _ _ _ shape lam),            histop_subhistograms,-           bucket,-           vs'+           (bucket, vs')            ) -> do-            let bucket' = toInt64Exp $ kernelResultSubExp bucket-                dest_w' = toInt64Exp dest_w-                bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'+            let bucket' = map toInt64Exp bucket+                dest_shape' = map toInt64Exp $ shapeDims dest_shape+                bucket_in_bounds =+                  inBounds (Slice (map DimFix bucket')) dest_shape'                 vs_params = takeLast (length vs') $ lambdaParams lam-                bucket_is = [bucket']              sComment "perform updates" $               sWhen bucket_in_bounds $ do                 dLParams $ lambdaParams lam                 sLoopNest shape $ \is' -> do                   forM_ (zip vs_params vs') $ \(p, res) ->-                    copyDWIMFix (paramName p) [] (kernelResultSubExp res) is'-                  updateHisto histop histop_subhistograms (bucket_is ++ is')+                    copyDWIMFix (paramName p) [] res is'+                  updateHisto histop histop_subhistograms (bucket' ++ is')    -- Copy the task-local subhistograms to the global subhistograms,   -- where they will be combined.@@ -257,17 +253,17 @@    -- Perform a segmented reduction over the subhistograms   forM_ (zip3 per_red_pes global_subhistograms histops) $ \(red_pes, hists, op) -> do-    bucket_id <- newVName "bucket_id"+    bucket_ids <-+      replicateM (shapeRank (histShape op)) (newVName "bucket_id")     subhistogram_id <- newVName "subhistogram_id" -    let num_buckets = histWidth op-        segred_space =+    let segred_space =           SegSpace (segFlat space) $             segment_dims-              ++ [(bucket_id, num_buckets)]+              ++ zip bucket_ids (shapeDims (histShape op))               ++ [(subhistogram_id, tvSize num_histos)] -        segred_op = SegBinOp Noncommutative (histOp op) (histNeutral op) (histShape op)+        segred_op = SegBinOp Noncommutative (histOp op) (histNeutral op) (histOpShape op)      nsubtasks_red <- dPrim "num_tasks" $ IntType Int32     red_code <- compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks_red $ \red_cont ->@@ -275,7 +271,7 @@         flip map hists $ \subhisto ->           ( Var subhisto,             map Imp.le64 $-              map fst segment_dims ++ [subhistogram_id, bucket_id]+              map fst segment_dims ++ [subhistogram_id] ++ bucket_ids           )      let ns_red = map (toInt64Exp . snd) $ unSegSpace segred_space@@ -331,15 +327,12 @@         let (red_res, map_res) =               splitFromEnd (length map_pes) $                 map kernelResultSubExp $ kernelBodyResult kbody-            (buckets, vs) = splitAt (length histops) red_res-            perOp = chunks $ map (length . histDest) histops--        forM_ (zip4 per_red_pes histops (perOp vs) buckets) $-          \(red_pes, HistOp dest_w _ _ _ shape lam, vs', bucket) -> do+        forM_ (zip3 per_red_pes histops (splitHistResults histops red_res)) $+          \(red_pes, HistOp dest_shape _ _ _ shape lam, (bucket, vs')) -> do             let (is_params, vs_params) = splitAt (length vs') $ lambdaParams lam-                bucket' = toInt64Exp bucket-                dest_w' = toInt64Exp dest_w-                bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'+                bucket' = map toInt64Exp bucket+                dest_shape' = map toInt64Exp $ shapeDims dest_shape+                bucket_in_bounds = inBounds (Slice (map DimFix bucket')) dest_shape'              sComment "save map-out results" $               forM_ (zip map_pes map_res) $ \(pe, res) ->@@ -350,12 +343,20 @@                 dLParams $ lambdaParams lam                 sLoopNest shape $ \vec_is -> do                   -- Index-                  let buck = toInt64Exp bucket                   forM_ (zip red_pes is_params) $ \(pe, p) ->-                    copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ [buck] ++ vec_is)+                    copyDWIMFix+                      (paramName p)+                      []+                      (Var $ patElemName pe)+                      (map Imp.le64 (init is) ++ bucket' ++ vec_is)                   -- Value at index                   forM_ (zip vs_params vs') $ \(p, v) ->                     copyDWIMFix (paramName p) [] v vec_is                   compileStms mempty (bodyStms $ lambdaBody lam) $                     forM_ (zip red_pes $ map resSubExp $ bodyResult $ lambdaBody lam) $-                      \(pe, se) -> copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ [buck] ++ vec_is) se []+                      \(pe, se) ->+                        copyDWIMFix+                          (patElemName pe)+                          (map Imp.le64 (init is) ++ bucket' ++ vec_is)+                          se+                          []

@@ -26,10 +26,10 @@ import Futhark.Compiler.Program import Futhark.IR import qualified Futhark.IR.SOACS as I+import qualified Futhark.IR.TypeCheck as I import Futhark.Internalise import Futhark.MonadFreshNames import Futhark.Pipeline-import qualified Futhark.TypeCheck as I import Futhark.Util.Log import Futhark.Util.Pretty (ppr, prettyText) import qualified Language.Futhark as E

@@ -25,7 +25,7 @@ import Futhark.IR.SOACS.SOAC hiding (HistOp (..)) import Futhark.IR.Syntax import Futhark.IR.Traversals-import qualified Futhark.TypeCheck as TypeCheck+import qualified Futhark.IR.TypeCheck as TC  -- | The phantom data type for the kernels representation. data GPU@@ -36,13 +36,13 @@ instance ASTRep GPU where   expTypesFromPat = return . expExtTypesFromPat -instance TypeCheck.CheckableOp GPU where+instance TC.CheckableOp GPU where   checkOp = typeCheckGPUOp Nothing     where       typeCheckGPUOp lvl =         typeCheckHostOp (typeCheckGPUOp . Just) lvl typeCheckSOAC -instance TypeCheck.Checkable GPU+instance TC.Checkable GPU  instance Buildable GPU where   mkBody = Body ()

@@ -32,11 +32,11 @@ import Futhark.IR.GPU.Sizes import Futhark.IR.Prop.Aliases import Futhark.IR.SegOp+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rep import Futhark.Transform.Rename import Futhark.Transform.Substitute-import qualified Futhark.TypeCheck as TC import Futhark.Util.Pretty   ( commasep,     parens,

@@ -24,11 +24,11 @@ import Futhark.IR.GPU.Simplify (simplifyKernelOp) import Futhark.IR.Mem import Futhark.IR.Mem.Simplify+import qualified Futhark.IR.TypeCheck as TC import Futhark.MonadFreshNames import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')-import qualified Futhark.TypeCheck as TC  data GPUMem 

@@ -30,11 +30,11 @@ import Futhark.IR.SegOp import Futhark.IR.Syntax import Futhark.IR.Traversals+import qualified Futhark.IR.TypeCheck as TypeCheck import qualified Futhark.Optimise.Simplify as Simplify import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rules import Futhark.Pass-import qualified Futhark.TypeCheck as TypeCheck  data MC 

@@ -23,12 +23,12 @@ import Futhark.IR.Aliases (Aliases) import Futhark.IR.Prop.Aliases import Futhark.IR.SegOp+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify as Simplify import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rep import Futhark.Transform.Rename import Futhark.Transform.Substitute-import qualified Futhark.TypeCheck as TC import Futhark.Util.Pretty   ( Pretty,     nestedBlock,

@@ -22,10 +22,10 @@ import Futhark.IR.Mem import Futhark.IR.Mem.Simplify import Futhark.IR.SegOp+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')-import qualified Futhark.TypeCheck as TC  data MCMem 

@@ -128,11 +128,11 @@ import Futhark.IR.Prop.Aliases import Futhark.IR.Syntax import Futhark.IR.Traversals+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rep import Futhark.Transform.Rename import Futhark.Transform.Substitute-import qualified Futhark.TypeCheck as TC import Futhark.Util import Futhark.Util.Pretty (indent, ppr, text, (<+>), (</>)) import qualified Futhark.Util.Pretty as PP

@@ -623,7 +623,7 @@       where         pHistOp =           SOAC.HistOp-            <$> pSubExp <* pComma+            <$> pShape <* pComma             <*> pSubExp <* pComma             <*> braces (pVName `sepBy` pComma) <* pComma             <*> braces (pSubExp `sepBy` pComma) <* pComma@@ -804,7 +804,7 @@       pure $ SegOp.SegBinOp comm lam nes shape     pHistOp =       SegOp.HistOp-        <$> pSubExp <* pComma+        <$> pShape <* pComma         <*> pSubExp <* pComma         <*> braces (pVName `sepBy` pComma) <* pComma         <*> braces (pSubExp `sepBy` pComma) <* pComma

@@ -308,7 +308,7 @@   ppr (Lambda [] (Body _ stms []) []) | stms == mempty = text "nilFn"   ppr (Lambda params body rettype) =     text "\\" <+> ppTuple' params-      <+/> colon <+> ppTupleLines' rettype <+> text "->"+      </> indent 2 (colon <+> ppTupleLines' rettype <+> text "->")       </> indent 2 (ppr body)  instance Pretty EntryPointType where

@@ -19,6 +19,7 @@     setOuterSize,     setDimSize,     setOuterDim,+    setOuterDims,     setDim,     setArrayDims,     peelArray,@@ -220,6 +221,10 @@ setOuterDim :: ShapeBase d -> d -> ShapeBase d setOuterDim = setDim 0 +-- | Replace some outermost dimensions of an array shape.+setOuterDims :: ShapeBase d -> Int -> ShapeBase d -> ShapeBase d+setOuterDims old k new = new <> stripDims k old+ -- | Replace the specified dimension of an array shape. setDim :: Int -> ShapeBase d -> d -> ShapeBase d setDim i (Shape ds) e = Shape $ take i ds ++ e : drop (i + 1) ds@@ -227,11 +232,7 @@ -- | @peelArray n t@ returns the type resulting from peeling the first -- @n@ array dimensions from @t@.  Returns @Nothing@ if @t@ has less -- than @n@ dimensions.-peelArray ::-  ArrayShape shape =>-  Int ->-  TypeBase shape u ->-  Maybe (TypeBase shape u)+peelArray :: Int -> TypeBase Shape u -> Maybe (TypeBase Shape u) peelArray 0 t = Just t peelArray n (Array et shape u)   | shapeRank shape == n = Just $ Prim et@@ -241,7 +242,7 @@ -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with -- @n@ indexes.-stripArray :: ArrayShape shape => Int -> TypeBase shape u -> TypeBase shape u+stripArray :: Int -> TypeBase Shape u -> TypeBase Shape u stripArray n (Array et shape u)   | n < shapeRank shape = Array et (stripDims n shape) u   | otherwise = Prim et@@ -278,7 +279,7 @@  -- | Return the immediate row-type of an array.  For @[[int]]@, this -- would be @[int]@.-rowType :: ArrayShape shape => TypeBase shape u -> TypeBase shape u+rowType :: TypeBase Shape u -> TypeBase Shape u rowType = stripArray 1  -- | A type is a primitive type if it is not an array or memory block.

@@ -47,7 +47,7 @@   ) import qualified Futhark.IR.Syntax as AST import Futhark.IR.Traversals-import qualified Futhark.TypeCheck as TypeCheck+import qualified Futhark.IR.TypeCheck as TC  -- This module could be written much nicer if Haskell had functors -- like Standard ML.  Instead, we have to abuse the namespace/module@@ -80,10 +80,10 @@  type PatElem = AST.PatElem SOACS -instance TypeCheck.CheckableOp SOACS where+instance TC.CheckableOp SOACS where   checkOp = typeCheckSOAC -instance TypeCheck.Checkable SOACS+instance TC.Checkable SOACS  instance Buildable SOACS where   mkBody = AST.Body ()

@@ -68,10 +68,10 @@ import Futhark.IR import Futhark.IR.Aliases (Aliases, removeLambdaAliases) import Futhark.IR.Prop.Aliases+import qualified Futhark.IR.TypeCheck as TC import Futhark.Optimise.Simplify.Rep import Futhark.Transform.Rename import Futhark.Transform.Substitute-import qualified Futhark.TypeCheck as TC import Futhark.Util (chunks, maybeNth) import Futhark.Util.Pretty (Doc, Pretty, comma, commasep, parens, ppr, text, (<+>), (</>)) import qualified Futhark.Util.Pretty as PP@@ -131,7 +131,7 @@  -- | Information about computing a single histogram. data HistOp rep = HistOp-  { histWidth :: SubExp,+  { histShape :: Shape,     -- | Race factor @RF@ means that only @1/RF@     -- bins are used.     histRaceFactor :: SubExp,@@ -430,8 +430,8 @@     <$> mapOnSOACSubExp tv w     <*> mapM (mapOnSOACVName tv) arrs     <*> mapM-      ( \(HistOp e rf op_arrs nes op) ->-          HistOp <$> mapOnSOACSubExp tv e+      ( \(HistOp shape rf op_arrs nes op) ->+          HistOp <$> mapM (mapOnSOACSubExp tv) shape             <*> mapOnSOACSubExp tv rf             <*> mapM (mapOnSOACVName tv) op_arrs             <*> mapM (mapOnSOACSubExp tv) nes@@ -507,7 +507,7 @@     (ws, ns, _) = unzip3 dests soacType (Hist _ _ ops _bucket_fun) = do   op <- ops-  map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op)+  map (`arrayOfShape` histShape op) (lambdaReturnType $ histOp op) soacType (Screma w _arrs form) =   scremaType w form @@ -739,9 +739,9 @@   TC.require [Prim int64] w    -- Check the operators.-  forM_ ops $ \(HistOp dest_w rf dests nes op) -> do+  forM_ ops $ \(HistOp dest_shape rf dests nes op) -> do     nes' <- mapM TC.checkArg nes-    TC.require [Prim int64] dest_w+    mapM_ (TC.require [Prim int64]) dest_shape     TC.require [Prim int64] rf      -- Operator type must match the type of neutral elements.@@ -757,7 +757,7 @@      -- Arrays must have proper type.     forM_ (zip nes_t dests) $ \(t, dest) -> do-      TC.requireI [t `arrayOfRow` dest_w] dest+      TC.requireI [t `arrayOfShape` dest_shape] dest       TC.consume =<< TC.lookupAliases dest    -- Types of input arrays must equal parameter types for bucket function.@@ -767,7 +767,9 @@   -- Return type of bucket function must be an index for each   -- operation followed by the values to write.   nes_ts <- concat <$> mapM (mapM subExpType . histNeutral) ops-  let bucket_ret_t = replicate (length ops) (Prim int64) ++ nes_ts+  let bucket_ret_t =+        concatMap ((`replicate` Prim int64) . shapeRank . histShape) ops+          ++ nes_ts   unless (bucket_ret_t == lambdaReturnType bucket_fun) $     TC.bad $       TC.TypeError $

@@ -24,6 +24,7 @@     -- * Details     HistOp (..),     histType,+    splitHistResults,     SegBinOp (..),     segBinOpResults,     segBinOpChunks,@@ -82,13 +83,13 @@   ) import Futhark.IR.Mem import Futhark.IR.Prop.Aliases+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rep import Futhark.Optimise.Simplify.Rule import Futhark.Tools import Futhark.Transform.Rename import Futhark.Transform.Substitute-import qualified Futhark.TypeCheck as TC import Futhark.Util (chunks, maybeNth) import Futhark.Util.Pretty   ( Pretty,@@ -126,7 +127,7 @@  -- | An operator for 'SegHist'. data HistOp rep = HistOp-  { histWidth :: SubExp,+  { histShape :: Shape,     histRaceFactor :: SubExp,     histDest :: [VName],     histNeutral :: [SubExp],@@ -135,7 +136,7 @@     -- SOACS representation), these are the logical     -- "dimensions".  This is used to generate more efficient     -- code.-    histShape :: Shape,+    histOpShape :: Shape,     histOp :: Lambda rep   }   deriving (Eq, Ord, Show)@@ -145,12 +146,20 @@ -- dealing with a segmented histogram. histType :: HistOp rep -> [Type] histType op =-  map-    ( (`arrayOfRow` histWidth op)-        . (`arrayOfShape` histShape op)-    )-    $ lambdaReturnType $ histOp op+  map (`arrayOfShape` (histShape op <> histOpShape op)) $+    lambdaReturnType $ histOp op +-- | Split reduction results returned by a 'KernelBody' into those+-- that correspond to indexes for the 'HistOps', and those that+-- correspond to value.+splitHistResults :: [HistOp rep] -> [SubExp] -> [([SubExp], [SubExp])]+splitHistResults ops res =+  let ranks = map (shapeRank . histShape) ops+      (idxs, vals) = splitAt (sum ranks) res+   in zip+        (chunks ranks idxs)+        (chunks (map (length . histDest) ops) vals)+ -- | An operator for 'SegScan' and 'SegRed'. data SegBinOp rep = SegBinOp   { segBinOpComm :: Commutativity,@@ -610,7 +619,7 @@       map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) segOpType (SegHist _ space ops _ _) = do   op <- ops-  let shape = Shape (segment_dims <> [histWidth op]) <> histShape op+  let shape = Shape segment_dims <> histShape op <> histOpShape op   map (`arrayOfShape` shape) (lambdaReturnType $ histOp op)   where     dims = segSpaceDims space@@ -667,8 +676,8 @@   mapM_ TC.checkType ts    TC.binding (scopeOfSegSpace space) $ do-    nes_ts <- forM ops $ \(HistOp dest_w rf dests nes shape op) -> do-      TC.require [Prim int64] dest_w+    nes_ts <- forM ops $ \(HistOp dest_shape rf dests nes shape op) -> do+      mapM_ (TC.require [Prim int64]) dest_shape       TC.require [Prim int64] rf       nes' <- mapM TC.checkArg nes       mapM_ (TC.require [Prim int64]) $ shapeDims shape@@ -686,9 +695,9 @@               ++ prettyTuple nes_t        -- Arrays must have proper type.-      let dest_shape = Shape (segment_dims <> [dest_w]) <> shape+      let dest_shape' = Shape segment_dims <> dest_shape <> shape       forM_ (zip nes_t dests) $ \(t, dest) -> do-        TC.requireI [t `arrayOfShape` dest_shape] dest+        TC.requireI [t `arrayOfShape` dest_shape'] dest         TC.consume =<< TC.lookupAliases dest        return $ map (`arrayOfShape` shape) nes_t@@ -697,7 +706,9 @@      -- Return type of bucket function must be an index for each     -- operation followed by the values to write.-    let bucket_ret_t = replicate (length ops) (Prim int64) ++ concat nes_ts+    let bucket_ret_t =+          concatMap ((`replicate` Prim int64) . shapeRank . histShape) ops+            ++ concat nes_ts     unless (bucket_ret_t == ts) $       TC.bad $         TC.TypeError $@@ -819,7 +830,7 @@     <*> mapOnSegOpBody tv body   where     onHistOp (HistOp w rf arrs nes shape op) =-      HistOp <$> mapOnSegOpSubExp tv w+      HistOp <$> mapM (mapOnSegOpSubExp tv) w         <*> mapOnSegOpSubExp tv rf         <*> mapM (mapOnSegOpVName tv) arrs         <*> mapM (mapOnSegOpSubExp tv) nes

@@ -22,11 +22,11 @@ import Futhark.IR.Prop import Futhark.IR.Syntax import Futhark.IR.Traversals+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify as Simplify import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rules import Futhark.Pass-import qualified Futhark.TypeCheck as TypeCheck  -- | The phantom type for the Seq representation. data Seq@@ -37,10 +37,10 @@ instance ASTRep Seq where   expTypesFromPat = return . expExtTypesFromPat -instance TypeCheck.CheckableOp Seq where+instance TC.CheckableOp Seq where   checkOp = pure -instance TypeCheck.Checkable Seq+instance TC.Checkable Seq  instance Buildable Seq where   mkBody = Body ()

@@ -19,10 +19,10 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.IR.Mem import Futhark.IR.Mem.Simplify+import qualified Futhark.IR.TypeCheck as TC import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')-import qualified Futhark.TypeCheck as TC  data SeqMem 

@@ -19,6 +19,7 @@     NoUniqueness (..),     ShapeBase (..),     Shape,+    stripDims,     Ext (..),     ExtSize,     ExtShape,@@ -116,6 +117,11 @@ instance Monoid (ShapeBase d) where   mempty = Shape mempty +-- | @stripDims n shape@ strips the outer @n@ dimensions from+-- @shape@.+stripDims :: Int -> ShapeBase d -> ShapeBase d+stripDims n (Shape dims) = Shape $ drop n dims+ -- | The size of an array as a list of subexpressions.  If a variable, -- that variable must be in scope where this array is used. type Shape = ShapeBase SubExp@@ -153,21 +159,15 @@   -- | Return the rank of an array with the given size.   shapeRank :: a -> Int -  -- | @stripDims n shape@ strips the outer @n@ dimensions from-  -- @shape@.-  stripDims :: Int -> a -> a-   -- | Check whether one shape if a subset of another shape.   subShapeOf :: a -> a -> Bool  instance ArrayShape (ShapeBase SubExp) where   shapeRank (Shape l) = length l-  stripDims n (Shape dims) = Shape $ drop n dims   subShapeOf = (==)  instance ArrayShape (ShapeBase ExtSize) where   shapeRank (Shape l) = length l-  stripDims n (Shape dims) = Shape $ drop n dims   subShapeOf (Shape ds1) (Shape ds2) =     -- Must agree on Free dimensions, and ds1 may not be existential     -- where ds2 is Free.  Existentials must also be congruent.@@ -195,7 +195,6 @@  instance ArrayShape Rank where   shapeRank (Rank x) = x-  stripDims n (Rank x) = Rank $ x - n   subShapeOf = (==)  -- | The memory space of a block.  If 'DefaultSpace', this is the "default"

@@ -0,0 +1,1534 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++-- | The type checker checks whether the program is type-consistent.+module Futhark.IR.TypeCheck+  ( -- * Interface+    checkProg,+    TypeError (..),+    ErrorCase (..),++    -- * Extensionality+    TypeM,+    bad,+    context,+    message,+    Checkable (..),+    CheckableOp (..),+    lookupVar,+    lookupAliases,+    checkOpWith,++    -- * Checkers+    require,+    requireI,+    requirePrimExp,+    checkSubExp,+    checkCerts,+    checkExp,+    checkStms,+    checkStm,+    checkType,+    checkExtType,+    matchExtPat,+    matchExtBranchType,+    argType,+    argAliases,+    noArgAliases,+    checkArg,+    checkSOACArrayArgs,+    checkLambda,+    checkBody,+    consume,+    consumeOnlyParams,+    binding,+    alternative,+  )+where++import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Parallel.Strategies+import Data.Bifunctor (second)+import Data.List (find, intercalate, isPrefixOf, sort)+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Set as S+import Futhark.Analysis.PrimExp+import Futhark.Construct (instantiateShapes)+import Futhark.IR.Aliases hiding (lookupAliases)+import Futhark.Util+import Futhark.Util.Pretty (Pretty, align, indent, ppr, prettyDoc, text, (<+>), (</>))++-- | Information about an error during type checking.  The 'Show'+-- instance for this type produces a human-readable description.+data ErrorCase rep+  = TypeError String+  | UnexpectedType (Exp rep) Type [Type]+  | ReturnTypeError Name [ExtType] [ExtType]+  | DupDefinitionError Name+  | DupParamError Name VName+  | DupPatError VName+  | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String)+  | UnknownVariableError VName+  | UnknownFunctionError Name+  | ParameterMismatch (Maybe Name) [Type] [Type]+  | SlicingError Int Int+  | BadAnnotation String Type Type+  | ReturnAliased Name VName+  | UniqueReturnAliased Name+  | NotAnArray VName Type+  | PermutationError [Int] Int (Maybe VName)++instance Checkable rep => Show (ErrorCase rep) where+  show (TypeError msg) =+    "Type error:\n" ++ msg+  show (UnexpectedType e _ []) =+    "Type of expression\n"+      ++ prettyDoc 160 (indent 2 $ ppr e)+      ++ "\ncannot have any type - possibly a bug in the type checker."+  show (UnexpectedType e t ts) =+    "Type of expression\n"+      ++ prettyDoc 160 (indent 2 $ ppr e)+      ++ "\nmust be one of "+      ++ intercalate ", " (map pretty ts)+      ++ ", but is "+      ++ pretty t+      ++ "."+  show (ReturnTypeError fname rettype bodytype) =+    "Declaration of function " ++ nameToString fname+      ++ " declares return type\n  "+      ++ prettyTuple rettype+      ++ "\nBut body has type\n  "+      ++ prettyTuple bodytype+  show (DupDefinitionError name) =+    "Duplicate definition of function " ++ nameToString name ++ ""+  show (DupParamError funname paramname) =+    "Parameter " ++ pretty paramname+      ++ " mentioned multiple times in argument list of function "+      ++ nameToString funname+      ++ "."+  show (DupPatError name) =+    "Variable " ++ pretty name ++ " bound twice in pattern."+  show (InvalidPatError pat t desc) =+    "Pat\n" ++ pretty pat+      ++ "\ncannot match value of type\n"+      ++ prettyTupleLines t+      ++ end+    where+      end = case desc of+        Nothing -> "."+        Just desc' -> ":\n" ++ desc'+  show (UnknownVariableError name) =+    "Use of unknown variable " ++ pretty name ++ "."+  show (UnknownFunctionError fname) =+    "Call of unknown function " ++ nameToString fname ++ "."+  show (ParameterMismatch fname expected got) =+    "In call of " ++ fname' ++ ":\n"+      ++ "expecting "+      ++ show nexpected+      ++ " arguments of type(s)\n"+      ++ intercalate ", " (map pretty expected)+      ++ "\nGot "+      ++ show ngot+      ++ " arguments of types\n"+      ++ intercalate ", " (map pretty got)+    where+      nexpected = length expected+      ngot = length got+      fname' = maybe "anonymous function" (("function " ++) . nameToString) fname+  show (SlicingError dims got) =+    show got ++ " indices given, but type of indexee has " ++ show dims ++ " dimension(s)."+  show (BadAnnotation desc expected got) =+    "Annotation of \"" ++ desc ++ "\" type of expression is " ++ pretty expected+      ++ ", but derived to be "+      ++ pretty got+      ++ "."+  show (ReturnAliased fname name) =+    "Unique return value of function " ++ nameToString fname+      ++ " is aliased to "+      ++ pretty name+      ++ ", which is not consumed."+  show (UniqueReturnAliased fname) =+    "A unique tuple element of return value of function "+      ++ nameToString fname+      ++ " is aliased to some other tuple component."+  show (NotAnArray e t) =+    "The expression " ++ pretty e+      ++ " is expected to be an array, but is "+      ++ pretty t+      ++ "."+  show (PermutationError perm rank name) =+    "The permutation (" ++ intercalate ", " (map show perm)+      ++ ") is not valid for array "+      ++ name'+      ++ "of rank "+      ++ show rank+      ++ "."+    where+      name' = maybe "" ((++ " ") . pretty) name++-- | A type error.+data TypeError rep = Error [String] (ErrorCase rep)++instance Checkable rep => Show (TypeError rep) where+  show (Error [] err) =+    show err+  show (Error msgs err) =+    intercalate "\n" msgs ++ "\n" ++ show err++-- | A tuple of a return type and a list of parameters, possibly+-- named.+type FunBinding rep = ([RetType (Aliases rep)], [FParam (Aliases rep)])++type VarBinding rep = NameInfo (Aliases rep)++data Usage+  = Consumed+  | Observed+  deriving (Eq, Ord, Show)++data Occurence = Occurence+  { observed :: Names,+    consumed :: Names+  }+  deriving (Eq, Show)++observation :: Names -> Occurence+observation = flip Occurence mempty++consumption :: Names -> Occurence+consumption = Occurence mempty++nullOccurence :: Occurence -> Bool+nullOccurence occ = observed occ == mempty && consumed occ == mempty++type Occurences = [Occurence]++allConsumed :: Occurences -> Names+allConsumed = mconcat . map consumed++seqOccurences :: Occurences -> Occurences -> Occurences+seqOccurences occurs1 occurs2 =+  filter (not . nullOccurence) (map filt occurs1) ++ occurs2+  where+    filt occ =+      occ {observed = observed occ `namesSubtract` postcons}+    postcons = allConsumed occurs2++altOccurences :: Occurences -> Occurences -> Occurences+altOccurences occurs1 occurs2 =+  filter (not . nullOccurence) (map filt occurs1) ++ occurs2+  where+    filt occ =+      occ+        { consumed = consumed occ `namesSubtract` postcons,+          observed = observed occ `namesSubtract` postcons+        }+    postcons = allConsumed occurs2++unOccur :: Names -> Occurences -> Occurences+unOccur to_be_removed = filter (not . nullOccurence) . map unOccur'+  where+    unOccur' occ =+      occ+        { observed = observed occ `namesSubtract` to_be_removed,+          consumed = consumed occ `namesSubtract` to_be_removed+        }++-- | The 'Consumption' data structure is used to keep track of which+-- variables have been consumed, as well as whether a violation has been detected.+data Consumption+  = ConsumptionError String+  | Consumption Occurences+  deriving (Show)++instance Semigroup Consumption where+  ConsumptionError e <> _ = ConsumptionError e+  _ <> ConsumptionError e = ConsumptionError e+  Consumption o1 <> Consumption o2+    | v : _ <- namesToList $ consumed_in_o1 `namesIntersection` used_in_o2 =+      ConsumptionError $ "Variable " <> pretty v <> " referenced after being consumed."+    | otherwise =+      Consumption $ o1 `seqOccurences` o2+    where+      consumed_in_o1 = mconcat $ map consumed o1+      used_in_o2 = mconcat $ map consumed o2 <> map observed o2++instance Monoid Consumption where+  mempty = Consumption mempty++-- | The environment contains a variable table and a function table.+-- Type checking happens with access to this environment.  The+-- function table is only initialised at the very beginning, but the+-- variable table will be extended during type-checking when+-- let-expressions are encountered.+data Env rep = Env+  { envVtable :: M.Map VName (VarBinding rep),+    envFtable :: M.Map Name (FunBinding rep),+    envCheckOp :: OpWithAliases (Op rep) -> TypeM rep (),+    envContext :: [String]+  }++data TState = TState+  { stateNames :: Names,+    stateCons :: Consumption+  }++-- | The type checker runs in this monad.+newtype TypeM rep a+  = TypeM+      ( ReaderT+          (Env rep)+          (StateT TState (Either (TypeError rep)))+          a+      )+  deriving+    ( Monad,+      Functor,+      Applicative,+      MonadReader (Env rep),+      MonadState TState+    )++instance+  Checkable rep =>+  HasScope (Aliases rep) (TypeM rep)+  where+  lookupType = fmap typeOf . lookupVar+  askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable+    where+      varType (name, dec) = Just (name, dec)++runTypeM ::+  Env rep ->+  TypeM rep a ->+  Either (TypeError rep) (a, Consumption)+runTypeM env (TypeM m) =+  second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty)++bad :: ErrorCase rep -> TypeM rep a+bad e = do+  messages <- asks envContext+  TypeM $ lift $ lift $ Left $ Error (reverse messages) e++tell :: Consumption -> TypeM rep ()+tell cons = modify $ \s -> s {stateCons = stateCons s <> cons}++-- | Add information about what is being type-checked to the current+-- context.  Liberal use of this combinator makes it easier to track+-- type errors, as the strings are added to type errors signalled via+-- 'bad'.+context ::+  String ->+  TypeM rep a ->+  TypeM rep a+context s = local $ \env -> env {envContext = s : envContext env}++message ::+  Pretty a =>+  String ->+  a ->+  String+message s x =+  prettyDoc 80 $+    text s <+> align (ppr x)++-- | Mark a name as bound.  If the name has been bound previously in+-- the program, report a type error.+bound :: VName -> TypeM rep ()+bound name = do+  already_seen <- gets $ nameIn name . stateNames+  when already_seen $+    bad $ TypeError $ "Name " ++ pretty name ++ " bound twice"+  modify $ \s -> s {stateNames = oneName name <> stateNames s}++occur :: Occurences -> TypeM rep ()+occur = tell . Consumption . filter (not . nullOccurence)++-- | Proclaim that we have made read-only use of the given variable.+-- No-op unless the variable is array-typed.+observe ::+  Checkable rep =>+  VName ->+  TypeM rep ()+observe name = do+  dec <- lookupVar name+  unless (primType $ typeOf dec) $+    occur [observation $ oneName name <> aliases dec]++-- | Proclaim that we have written to the given variables.+consume :: Checkable rep => Names -> TypeM rep ()+consume als = do+  scope <- askScope+  let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope)+  occur [consumption $ namesFromList $ filter isArray $ namesToList als]++collectOccurences :: TypeM rep a -> TypeM rep (a, Occurences)+collectOccurences m = do+  old <- gets stateCons+  modify $ \s -> s {stateCons = mempty}+  x <- m+  new <- gets stateCons+  modify $ \s -> s {stateCons = old}+  o <- checkConsumption new+  pure (x, o)++checkOpWith ::+  (OpWithAliases (Op rep) -> TypeM rep ()) ->+  TypeM rep a ->+  TypeM rep a+checkOpWith checker = local $ \env -> env {envCheckOp = checker}++checkConsumption :: Consumption -> TypeM rep Occurences+checkConsumption (ConsumptionError e) = bad $ TypeError e+checkConsumption (Consumption os) = return os++alternative :: TypeM rep a -> TypeM rep b -> TypeM rep (a, b)+alternative m1 m2 = do+  (x, os1) <- collectOccurences m1+  (y, os2) <- collectOccurences m2+  tell $ Consumption $ os1 `altOccurences` os2+  pure (x, y)++-- | Permit consumption of only the specified names.  If one of these+-- names is consumed, the consumption will be rewritten to be a+-- consumption of the corresponding alias set.  Consumption of+-- anything else will result in a type error.+consumeOnlyParams :: [(VName, Names)] -> TypeM rep a -> TypeM rep a+consumeOnlyParams consumable m = do+  (x, os) <- collectOccurences m+  tell . Consumption =<< mapM inspect os+  return x+  where+    inspect o = do+      new_consumed <- mconcat <$> mapM wasConsumed (namesToList $ consumed o)+      return o {consumed = new_consumed}+    wasConsumed v+      | Just als <- lookup v consumable = return als+      | otherwise =+        bad $+          TypeError $+            unlines+              [ pretty v ++ " was invalidly consumed.",+                what ++ " can be consumed here."+              ]+    what+      | null consumable = "Nothing"+      | otherwise = "Only " ++ intercalate ", " (map (pretty . fst) consumable)++-- | Given the immediate aliases, compute the full transitive alias+-- set (including the immediate aliases).+expandAliases :: Names -> Env rep -> Names+expandAliases names env = names <> aliasesOfAliases+  where+    aliasesOfAliases = mconcat . map look . namesToList $ names+    look k = case M.lookup k $ envVtable env of+      Just (LetName (als, _)) -> unAliases als+      _ -> mempty++binding ::+  Checkable rep =>+  Scope (Aliases rep) ->+  TypeM rep a ->+  TypeM rep a+binding stms = check . local (`bindVars` stms)+  where+    bindVars = M.foldlWithKey' bindVar+    boundnames = M.keys stms++    bindVar env name (LetName (AliasDec als, dec)) =+      let als'+            | primType (typeOf dec) = mempty+            | otherwise = expandAliases als env+       in env+            { envVtable =+                M.insert name (LetName (AliasDec als', dec)) $ envVtable env+            }+    bindVar env name dec =+      env {envVtable = M.insert name dec $ envVtable env}++    -- Check whether the bound variables have been used correctly+    -- within their scope.+    check m = do+      mapM_ bound $ M.keys stms+      (a, os) <- collectOccurences m+      tell $ Consumption $ unOccur (namesFromList boundnames) os+      return a++lookupVar :: VName -> TypeM rep (NameInfo (Aliases rep))+lookupVar name = do+  stm <- asks $ M.lookup name . envVtable+  case stm of+    Nothing -> bad $ UnknownVariableError name+    Just dec -> return dec++lookupAliases :: Checkable rep => VName -> TypeM rep Names+lookupAliases name = do+  info <- lookupVar name+  return $+    if primType $ typeOf info+      then mempty+      else oneName name <> aliases info++aliases :: NameInfo (Aliases rep) -> Names+aliases (LetName (als, _)) = unAliases als+aliases _ = mempty++subExpAliasesM :: Checkable rep => SubExp -> TypeM rep Names+subExpAliasesM Constant {} = return mempty+subExpAliasesM (Var v) = lookupAliases v++lookupFun ::+  Checkable rep =>+  Name ->+  [SubExp] ->+  TypeM rep ([RetType rep], [DeclType])+lookupFun fname args = do+  stm <- asks $ M.lookup fname . envFtable+  case stm of+    Nothing -> bad $ UnknownFunctionError fname+    Just (ftype, params) -> do+      argts <- mapM subExpType args+      case applyRetType ftype params $ zip args argts of+        Nothing ->+          bad $ ParameterMismatch (Just fname) (map paramType params) argts+        Just rt ->+          return (rt, map paramDeclType params)++-- | @checkAnnotation loc s t1 t2@ checks if @t2@ is equal to+-- @t1@.  If not, a 'BadAnnotation' is raised.+checkAnnotation ::+  String ->+  Type ->+  Type ->+  TypeM rep ()+checkAnnotation desc t1 t2+  | t2 == t1 = return ()+  | otherwise = bad $ BadAnnotation desc t1 t2++-- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is+-- not a subtype of one of the types in @ts@.+require :: Checkable rep => [Type] -> SubExp -> TypeM rep ()+require ts se = do+  t <- checkSubExp se+  unless (t `elem` ts) $+    bad $ UnexpectedType (BasicOp $ SubExp se) t ts++-- | Variant of 'require' working on variable names.+requireI :: Checkable rep => [Type] -> VName -> TypeM rep ()+requireI ts ident = require ts $ Var ident++checkArrIdent ::+  Checkable rep =>+  VName ->+  TypeM rep Type+checkArrIdent v = do+  t <- lookupType v+  case t of+    Array {} -> return t+    _ -> bad $ NotAnArray v t++checkAccIdent ::+  Checkable rep =>+  VName ->+  TypeM rep (Shape, [Type])+checkAccIdent v = do+  t <- lookupType v+  case t of+    Acc _ ispace ts _ ->+      pure (ispace, ts)+    _ ->+      bad . TypeError $+        pretty v+          ++ " should be an accumulator but is of type "+          ++ pretty t++-- | Type check a program containing arbitrary type information,+-- yielding either a type error or a program with complete type+-- information.+checkProg ::+  Checkable rep =>+  Prog (Aliases rep) ->+  Either (TypeError rep) ()+checkProg (Prog consts funs) = do+  let typeenv =+        Env+          { envVtable = M.empty,+            envFtable = mempty,+            envContext = [],+            envCheckOp = checkOp+          }+  let onFunction ftable vtable fun =+        fmap fst $+          runTypeM typeenv $+            local (\env -> env {envFtable = ftable, envVtable = vtable}) $+              checkFun fun+  (ftable, _) <- runTypeM typeenv buildFtable+  (vtable, _) <-+    runTypeM typeenv {envFtable = ftable} $+      checkStms consts $ asks envVtable+  sequence_ $ parMap rpar (onFunction ftable vtable) funs+  where+    buildFtable = do+      table <- initialFtable+      foldM expand table funs+    expand ftable (FunDef _ _ name ret params _)+      | M.member name ftable =+        bad $ DupDefinitionError name+      | otherwise =+        return $ M.insert name (ret, params) ftable++initialFtable ::+  Checkable rep =>+  TypeM rep (M.Map Name (FunBinding rep))+initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions+  where+    addBuiltin (fname, (t, ts)) = do+      ps <- mapM (primFParam name) ts+      return (fname, ([primRetType t], ps))+    name = VName (nameFromString "x") 0++checkFun ::+  Checkable rep =>+  FunDef (Aliases rep) ->+  TypeM rep ()+checkFun (FunDef _ _ fname rettype params body) =+  context ("In function " ++ nameToString fname) $+    checkFun'+      ( fname,+        map declExtTypeOf rettype,+        funParamsToNameInfos params+      )+      (Just consumable)+      $ do+        checkFunParams params+        checkRetType rettype+        context "When checking function body" $ checkFunBody rettype body+  where+    consumable =+      [ (paramName param, mempty)+        | param <- params,+          unique $ paramDeclType param+      ]++funParamsToNameInfos ::+  [FParam rep] ->+  [(VName, NameInfo (Aliases rep))]+funParamsToNameInfos = map nameTypeAndDec+  where+    nameTypeAndDec fparam =+      ( paramName fparam,+        FParamName $ paramDec fparam+      )++checkFunParams ::+  Checkable rep =>+  [FParam rep] ->+  TypeM rep ()+checkFunParams = mapM_ $ \param ->+  context ("In function parameter " ++ pretty param) $+    checkFParamDec (paramName param) (paramDec param)++checkLambdaParams ::+  Checkable rep =>+  [LParam rep] ->+  TypeM rep ()+checkLambdaParams = mapM_ $ \param ->+  context ("In lambda parameter " ++ pretty param) $+    checkLParamDec (paramName param) (paramDec param)++checkFun' ::+  Checkable rep =>+  ( Name,+    [DeclExtType],+    [(VName, NameInfo (Aliases rep))]+  ) ->+  Maybe [(VName, Names)] ->+  TypeM rep [Names] ->+  TypeM rep ()+checkFun' (fname, rettype, params) consumable check = do+  checkNoDuplicateParams+  binding (M.fromList params) $+    maybe id consumeOnlyParams consumable $ do+      body_aliases <- check+      scope <- askScope+      let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)+      context+        ( "When checking the body aliases: "+            ++ pretty (map namesToList body_aliases)+        )+        $ checkReturnAlias $ map (namesFromList . filter isArray . namesToList) body_aliases+  where+    param_names = map fst params++    checkNoDuplicateParams = foldM_ expand [] param_names++    expand seen pname+      | Just _ <- find (== pname) seen =+        bad $ DupParamError fname pname+      | otherwise =+        return $ pname : seen+    checkReturnAlias =+      foldM_ checkReturnAlias' mempty . returnAliasing rettype++    checkReturnAlias' seen (Unique, names)+      | any (`S.member` S.map fst seen) $ namesToList names =+        bad $ UniqueReturnAliased fname+      | otherwise = do+        consume names+        return $ seen <> tag Unique names+    checkReturnAlias' seen (Nonunique, names)+      | any (`S.member` seen) $ tag Unique names =+        bad $ UniqueReturnAliased fname+      | otherwise = return $ seen <> tag Nonunique names++    tag u = S.fromList . map (,u) . namesToList++    returnAliasing expected got =+      reverse $+        zip (reverse (map uniqueness expected) ++ repeat Nonunique) $+          reverse got++checkSubExp :: Checkable rep => SubExp -> TypeM rep Type+checkSubExp (Constant val) =+  return $ Prim $ primValueType val+checkSubExp (Var ident) = context ("In subexp " ++ pretty ident) $ do+  observe ident+  lookupType ident++checkCerts :: Checkable rep => Certs -> TypeM rep ()+checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs++checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type+checkSubExpRes (SubExpRes cs se) = do+  checkCerts cs+  checkSubExp se++checkStms ::+  Checkable rep =>+  Stms (Aliases rep) ->+  TypeM rep a ->+  TypeM rep a+checkStms origstms m = delve $ stmsToList origstms+  where+    delve (stm@(Let pat _ e) : stms) = do+      context (pretty $ "In expression of statement" </> indent 2 (ppr pat)) $+        checkExp e+      checkStm stm $+        delve stms+    delve [] =+      m++checkResult ::+  Checkable rep =>+  Result ->+  TypeM rep ()+checkResult = mapM_ checkSubExpRes++checkFunBody ::+  Checkable rep =>+  [RetType rep] ->+  Body (Aliases rep) ->+  TypeM rep [Names]+checkFunBody rt (Body (_, rep) stms res) = do+  checkBodyDec rep+  checkStms stms $ do+    context "When checking body result" $ checkResult res+    context "When matching declared return type to result of body" $+      matchReturnType rt res+    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res+  where+    bound_here = namesFromList $ M.keys $ scopeOf stms++checkLambdaBody ::+  Checkable rep =>+  [Type] ->+  Body (Aliases rep) ->+  TypeM rep [Names]+checkLambdaBody ret (Body (_, rep) stms res) = do+  checkBodyDec rep+  checkStms stms $ do+    checkLambdaResult ret res+    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res+  where+    bound_here = namesFromList $ M.keys $ scopeOf stms++checkLambdaResult ::+  Checkable rep =>+  [Type] ->+  Result ->+  TypeM rep ()+checkLambdaResult ts es+  | length ts /= length es =+    bad $+      TypeError $+        "Lambda has return type " ++ prettyTuple ts+          ++ " describing "+          ++ show (length ts)+          ++ " values, but body returns "+          ++ show (length es)+          ++ " values: "+          ++ prettyTuple es+  | otherwise = forM_ (zip ts es) $ \(t, e) -> do+    et <- checkSubExpRes e+    unless (et == t) $+      bad $+        TypeError $+          "Subexpression " ++ pretty e ++ " has type " ++ pretty et+            ++ " but expected "+            ++ pretty t++checkBody ::+  Checkable rep =>+  Body (Aliases rep) ->+  TypeM rep [Names]+checkBody (Body (_, rep) stms res) = do+  checkBodyDec rep+  checkStms stms $ do+    checkResult res+    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res+  where+    bound_here = namesFromList $ M.keys $ scopeOf stms++checkBasicOp :: Checkable rep => BasicOp -> TypeM rep ()+checkBasicOp (SubExp es) =+  void $ checkSubExp es+checkBasicOp (Opaque _ es) =+  void $ checkSubExp es+checkBasicOp (ArrayLit [] _) =+  return ()+checkBasicOp (ArrayLit (e : es') t) = do+  let check elemt eleme = do+        elemet <- checkSubExp eleme+        unless (elemet == elemt) $+          bad $+            TypeError $+              pretty elemet+                ++ " is not of expected type "+                ++ pretty elemt+                ++ "."+  et <- checkSubExp e++  -- Compare that type with the one given for the array literal.+  checkAnnotation "array-element" t et++  mapM_ (check et) es'+checkBasicOp (UnOp op e) = require [Prim $ unOpType op] e+checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2+checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2+checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e+checkBasicOp (Index ident (Slice idxes)) = do+  vt <- lookupType ident+  observe ident+  when (arrayRank vt /= length idxes) $+    bad $ SlicingError (arrayRank vt) (length idxes)+  mapM_ checkDimIndex idxes+checkBasicOp (Update _ src (Slice idxes) se) = do+  src_t <- checkArrIdent src+  when (arrayRank src_t /= length idxes) $+    bad $ SlicingError (arrayRank src_t) (length idxes)++  se_aliases <- subExpAliasesM se+  when (src `nameIn` se_aliases) $+    bad $ TypeError "The target of an Update must not alias the value to be written."++  mapM_ checkDimIndex idxes+  require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims (Slice idxes))) NoUniqueness] se+  consume =<< lookupAliases src+checkBasicOp (FlatIndex ident slice) = do+  vt <- lookupType ident+  observe ident+  when (arrayRank vt /= 1) $+    bad $ SlicingError (arrayRank vt) 1+  checkFlatSlice slice+checkBasicOp (FlatUpdate src slice v) = do+  src_t <- checkArrIdent src+  when (arrayRank src_t /= 1) $+    bad $ SlicingError (arrayRank src_t) 1++  v_aliases <- lookupAliases v+  when (src `nameIn` v_aliases) $+    bad $ TypeError "The target of an Update must not alias the value to be written."++  checkFlatSlice slice+  requireI [arrayOf (Prim (elemType src_t)) (Shape (flatSliceDims slice)) NoUniqueness] v+  consume =<< lookupAliases src+checkBasicOp (Iota e x s et) = do+  require [Prim int64] e+  require [Prim $ IntType et] x+  require [Prim $ IntType et] s+checkBasicOp (Replicate (Shape dims) valexp) = do+  mapM_ (require [Prim int64]) dims+  void $ checkSubExp valexp+checkBasicOp (Scratch _ shape) =+  mapM_ checkSubExp shape+checkBasicOp (Reshape newshape arrexp) = do+  rank <- arrayRank <$> checkArrIdent arrexp+  mapM_ (require [Prim int64] . newDim) newshape+  zipWithM_ (checkDimChange rank) newshape [0 ..]+  where+    checkDimChange _ (DimNew _) _ =+      return ()+    checkDimChange rank (DimCoercion se) i+      | i >= rank =+        bad $+          TypeError $+            "Asked to coerce dimension " ++ show i ++ " to " ++ pretty se+              ++ ", but array "+              ++ pretty arrexp+              ++ " has only "+              ++ pretty rank+              ++ " dimensions"+      | otherwise =+        return ()+checkBasicOp (Rearrange perm arr) = do+  arrt <- lookupType arr+  let rank = arrayRank arrt+  when (length perm /= rank || sort perm /= [0 .. rank -1]) $+    bad $ PermutationError perm rank $ Just arr+checkBasicOp (Rotate rots arr) = do+  arrt <- lookupType arr+  let rank = arrayRank arrt+  mapM_ (require [Prim int64]) rots+  when (length rots /= rank) $+    bad $+      TypeError $+        "Cannot rotate " ++ show (length rots)+          ++ " dimensions of "+          ++ show rank+          ++ "-dimensional array."+checkBasicOp (Concat i arr1exp arr2exps ressize) = do+  arr1t <- checkArrIdent arr1exp+  arr2ts <- mapM checkArrIdent arr2exps+  let success =+        all+          ( (== dropAt i 1 (arrayDims arr1t))+              . dropAt i 1+              . arrayDims+          )+          arr2ts+  unless success $+    bad $+      TypeError $+        "Types of arguments to concat do not match.  Got "+          ++ pretty arr1t+          ++ " and "+          ++ intercalate ", " (map pretty arr2ts)+  require [Prim int64] ressize+checkBasicOp (Copy e) =+  void $ checkArrIdent e+checkBasicOp (Manifest perm arr) =+  checkBasicOp $ Rearrange perm arr -- Basically same thing!+checkBasicOp (Assert e (ErrorMsg parts) _) = do+  require [Prim Bool] e+  mapM_ checkPart parts+  where+    checkPart ErrorString {} = return ()+    checkPart (ErrorVal t x) = require [Prim t] x+checkBasicOp (UpdateAcc acc is ses) = do+  (shape, ts) <- checkAccIdent acc++  unless (length ses == length ts) $+    bad $+      TypeError $+        "Accumulator requires "+          ++ show (length ts)+          ++ " values, but "+          ++ show (length ses)+          ++ " provided."++  unless (length is == shapeRank shape) $+    bad $+      TypeError $+        "Accumulator requires "+          ++ show (shapeRank shape)+          ++ " indices, but "+          ++ show (length is)+          ++ " provided."++  zipWithM_ require (map pure ts) ses+  consume =<< lookupAliases acc++matchLoopResultExt ::+  Checkable rep =>+  [Param DeclType] ->+  Result ->+  TypeM rep ()+matchLoopResultExt merge loopres = do+  let rettype_ext =+        existentialiseExtTypes (map paramName merge) $+          staticShapes $ map typeOf merge++  bodyt <- mapM subExpResType loopres++  case instantiateShapes (fmap resSubExp . (`maybeNth` loopres)) rettype_ext of+    Nothing ->+      bad $+        ReturnTypeError+          (nameFromString "<loop body>")+          rettype_ext+          (staticShapes bodyt)+    Just rettype' ->+      unless (bodyt `subtypesOf` rettype') $+        bad $+          ReturnTypeError+            (nameFromString "<loop body>")+            (staticShapes rettype')+            (staticShapes bodyt)++checkExp ::+  Checkable rep =>+  Exp (Aliases rep) ->+  TypeM rep ()+checkExp (BasicOp op) = checkBasicOp op+checkExp (If e1 e2 e3 info) = do+  require [Prim Bool] e1+  _ <-+    context "in true branch" (checkBody e2)+      `alternative` context "in false branch" (checkBody e3)+  context "in true branch" $ matchBranchType (ifReturns info) e2+  context "in false branch" $ matchBranchType (ifReturns info) e3+checkExp (Apply fname args rettype_annot _) = do+  (rettype_derived, paramtypes) <- lookupFun fname $ map fst args+  argflows <- mapM (checkArg . fst) args+  when (rettype_derived /= rettype_annot) $+    bad . TypeError . pretty $+      "Expected apply result type:"+        </> indent 2 (ppr rettype_derived)+        </> "But annotation is:"+        </> indent 2 (ppr rettype_annot)+  consumeArgs paramtypes argflows+checkExp (DoLoop merge form loopbody) = do+  let (mergepat, mergeexps) = unzip merge+  mergeargs <- mapM checkArg mergeexps++  checkLoopArgs++  binding (scopeOf form) $ do+    form_consumable <- checkForm mergeargs form++    let rettype = map paramDeclType mergepat+        consumable =+          [ (paramName param, mempty)+            | param <- mergepat,+              unique $ paramDeclType param+          ]+            ++ form_consumable++    context "Inside the loop body" $+      checkFun'+        ( nameFromString "<loop body>",+          staticShapes rettype,+          funParamsToNameInfos mergepat+        )+        (Just consumable)+        $ do+          checkFunParams mergepat+          checkBodyDec $ snd $ bodyDec loopbody++          checkStms (bodyStms loopbody) $ do+            context "In loop body result" $+              checkResult $ bodyResult loopbody++            context "When matching result of body with loop parameters" $+              matchLoopResult (map fst merge) $ bodyResult loopbody++            let bound_here =+                  namesFromList $ M.keys $ scopeOf $ bodyStms loopbody+            map (`namesSubtract` bound_here)+              <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody)+  where+    checkLoopVar (p, a) = do+      a_t <- lookupType a+      observe a+      case peelArray 1 a_t of+        Just a_t_r -> do+          checkLParamDec (paramName p) $ paramDec p+          unless (a_t_r `subtypeOf` typeOf (paramDec p)) $+            bad $+              TypeError $+                "Loop parameter " ++ pretty p+                  ++ " not valid for element of "+                  ++ pretty a+                  ++ ", which has row type "+                  ++ pretty a_t_r+          als <- lookupAliases a+          pure (paramName p, als)+        _ ->+          bad $+            TypeError $+              "Cannot loop over " ++ pretty a+                ++ " of type "+                ++ pretty a_t+    checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do+      iparam <- primFParam loopvar $ IntType it+      let mergepat = map fst merge+          funparams = iparam : mergepat+          paramts = map paramDeclType funparams++      consumable <- mapM checkLoopVar loopvars+      boundarg <- checkArg boundexp+      checkFuncall Nothing paramts $ boundarg : mergeargs+      pure consumable+    checkForm mergeargs (WhileLoop cond) = do+      case find ((== cond) . paramName . fst) merge of+        Just (condparam, _) ->+          unless (paramType condparam == Prim Bool) $+            bad $+              TypeError $+                "Conditional '" ++ pretty cond ++ "' of while-loop is not boolean, but "+                  ++ pretty (paramType condparam)+                  ++ "."+        Nothing ->+          bad $+            TypeError $+              "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge variable."+      let mergepat = map fst merge+          funparams = mergepat+          paramts = map paramDeclType funparams+      checkFuncall Nothing paramts mergeargs+      pure mempty++    checkLoopArgs = do+      let (params, args) = unzip merge++      argtypes <- mapM subExpType args++      let expected = expectedTypes (map paramName params) params args+      unless (expected == argtypes) . bad . TypeError . pretty $+        "Loop parameters"+          </> indent 2 (ppTuple' params)+          </> "cannot accept initial values"+          </> indent 2 (ppTuple' args)+          </> "of types"+          </> indent 2 (ppTuple' argtypes)+checkExp (WithAcc inputs lam) = do+  unless (length (lambdaParams lam) == 2 * num_accs) $+    bad . TypeError $+      show (length (lambdaParams lam))+        ++ " parameters, but "+        ++ show num_accs+        ++ " accumulators."++  let cert_params = take num_accs $ lambdaParams lam+  acc_args <- forM (zip inputs cert_params) $ \((shape, arrs, op), p) -> do+    mapM_ (require [Prim int64]) (shapeDims shape)+    elem_ts <- forM arrs $ \arr -> do+      arr_t <- lookupType arr+      unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $+        bad . TypeError $ pretty arr <> " is not an array of outer shape " <> pretty shape+      consume =<< lookupAliases arr+      pure $ stripArray (shapeRank shape) arr_t++    case op of+      Just (op_lam, nes) -> do+        let mkArrArg t = (t, mempty)+        nes_ts <- mapM checkSubExp nes+        unless (nes_ts == lambdaReturnType op_lam) $+          bad $+            TypeError $+              unlines+                [ "Accumulator operator return type: " ++ pretty (lambdaReturnType op_lam),+                  "Type of neutral elements: " ++ pretty nes_ts+                ]+        checkLambda op_lam $+          replicate (shapeRank shape) (Prim int64, mempty)+            ++ map mkArrArg (elem_ts ++ elem_ts)+      Nothing ->+        return ()++    pure (Acc (paramName p) shape elem_ts NoUniqueness, mempty)++  checkAnyLambda False lam $ replicate num_accs (Prim Unit, mempty) ++ acc_args+  where+    num_accs = length inputs+checkExp (Op op) = do+  checker <- asks envCheckOp+  checker op++checkSOACArrayArgs ::+  Checkable rep =>+  SubExp ->+  [VName] ->+  TypeM rep [Arg]+checkSOACArrayArgs width = mapM checkSOACArrayArg+  where+    checkSOACArrayArg v = do+      (t, als) <- checkArg $ Var v+      case t of+        Acc {} -> pure (t, als)+        Array {} -> do+          let argSize = arraySize 0 t+          unless (argSize == width) $+            bad . TypeError $+              "SOAC argument " ++ pretty v ++ " has outer size "+                ++ pretty argSize+                ++ ", but width of SOAC is "+                ++ pretty width+          pure (rowType t, als)+        _ ->+          bad . TypeError $+            "SOAC argument " ++ pretty v ++ " is not an array"++checkType ::+  Checkable rep =>+  TypeBase Shape u ->+  TypeM rep ()+checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d+checkType (Acc cert shape ts _) = do+  requireI [Prim Unit] cert+  mapM_ (require [Prim int64]) $ shapeDims shape+  mapM_ checkType ts+checkType t = mapM_ checkSubExp $ arrayDims t++checkExtType ::+  Checkable rep =>+  TypeBase ExtShape u ->+  TypeM rep ()+checkExtType = mapM_ checkExtDim . shapeDims . arrayShape+  where+    checkExtDim (Free se) = void $ checkSubExp se+    checkExtDim (Ext _) = return ()++checkCmpOp ::+  Checkable rep =>+  CmpOp ->+  SubExp ->+  SubExp ->+  TypeM rep ()+checkCmpOp (CmpEq t) x y = do+  require [Prim t] x+  require [Prim t] y+checkCmpOp (CmpUlt t) x y = checkBinOpArgs (IntType t) x y+checkCmpOp (CmpUle t) x y = checkBinOpArgs (IntType t) x y+checkCmpOp (CmpSlt t) x y = checkBinOpArgs (IntType t) x y+checkCmpOp (CmpSle t) x y = checkBinOpArgs (IntType t) x y+checkCmpOp (FCmpLt t) x y = checkBinOpArgs (FloatType t) x y+checkCmpOp (FCmpLe t) x y = checkBinOpArgs (FloatType t) x y+checkCmpOp CmpLlt x y = checkBinOpArgs Bool x y+checkCmpOp CmpLle x y = checkBinOpArgs Bool x y++checkBinOpArgs ::+  Checkable rep =>+  PrimType ->+  SubExp ->+  SubExp ->+  TypeM rep ()+checkBinOpArgs t e1 e2 = do+  require [Prim t] e1+  require [Prim t] e2++checkPatElem ::+  Checkable rep =>+  PatElemT (LetDec rep) ->+  TypeM rep ()+checkPatElem (PatElem name dec) =+  context ("When checking pattern element " ++ pretty name) $+    checkLetBoundDec name dec++checkFlatDimIndex ::+  Checkable rep =>+  FlatDimIndex SubExp ->+  TypeM rep ()+checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s]++checkFlatSlice ::+  Checkable rep =>+  FlatSlice SubExp ->+  TypeM rep ()+checkFlatSlice (FlatSlice offset idxs) = do+  require [Prim int64] offset+  mapM_ checkFlatDimIndex idxs++checkDimIndex ::+  Checkable rep =>+  DimIndex SubExp ->+  TypeM rep ()+checkDimIndex (DimFix i) = require [Prim int64] i+checkDimIndex (DimSlice i n s) = mapM_ (require [Prim int64]) [i, n, s]++checkStm ::+  Checkable rep =>+  Stm (Aliases rep) ->+  TypeM rep a ->+  TypeM rep a+checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do+  context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs+  context "When checking expression annotation" $ checkExpDec dec+  context ("When matching\n" ++ message "  " pat ++ "\nwith\n" ++ message "  " e) $+    matchPat pat e+  binding (maybeWithoutAliases $ scopeOf stm) $ do+    mapM_ checkPatElem (patElems $ removePatAliases pat)+    m+  where+    -- FIXME: this is wrong.  However, the core language type system+    -- is not strong enough to fully capture the aliases we want (see+    -- issue #803).  Since we eventually inline everything anyway, and+    -- our intra-procedural alias analysis is much simpler and+    -- correct, I could not justify spending time on improving the+    -- inter-procedural alias analysis.  If we ever stop inlining+    -- everything, probably we need to go back and refine this.+    maybeWithoutAliases =+      case stmExp stm of+        Apply {} -> M.map withoutAliases+        _ -> id+    withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec)+    withoutAliases info = info++matchExtPat ::+  Checkable rep =>+  Pat (Aliases rep) ->+  [ExtType] ->+  TypeM rep ()+matchExtPat pat ts =+  unless (expExtTypesFromPat pat == ts) $+    bad $ InvalidPatError pat ts Nothing++matchExtReturnType ::+  Checkable rep =>+  [ExtType] ->+  Result ->+  TypeM rep ()+matchExtReturnType rettype res = do+  ts <- mapM subExpResType res+  matchExtReturns rettype res ts++matchExtBranchType ::+  Checkable rep =>+  [ExtType] ->+  Body (Aliases rep) ->+  TypeM rep ()+matchExtBranchType rettype (Body _ stms res) = do+  ts <- extendedScope (traverse subExpResType res) stmscope+  matchExtReturns rettype res ts+  where+    stmscope = scopeOf stms++matchExtReturns :: [ExtType] -> Result -> [Type] -> TypeM rep ()+matchExtReturns rettype res ts = do+  let problem :: TypeM rep a+      problem =+        bad $+          TypeError $+            unlines+              [ "Type annotation is",+                "  " ++ prettyTuple rettype,+                "But result returns type",+                "  " ++ prettyTuple ts+              ]++  unless (length res == length rettype) problem++  let ctx_vals = zip res ts+      instantiateExt i = case maybeNth i ctx_vals of+        Just (SubExpRes _ se, Prim (IntType Int64)) -> return se+        _ -> problem++  rettype' <- instantiateShapes instantiateExt rettype++  unless (rettype' == ts) problem++validApply ::+  ArrayShape shape =>+  [TypeBase shape Uniqueness] ->+  [TypeBase shape NoUniqueness] ->+  Bool+validApply expected got =+  length got == length expected+    && and+      ( zipWith+          subtypeOf+          (map rankShaped got)+          (map (fromDecl . rankShaped) expected)+      )++type Arg = (Type, Names)++argType :: Arg -> Type+argType (t, _) = t++-- | Remove all aliases from the 'Arg'.+argAliases :: Arg -> Names+argAliases (_, als) = als++noArgAliases :: Arg -> Arg+noArgAliases (t, _) = (t, mempty)++checkArg ::+  Checkable rep =>+  SubExp ->+  TypeM rep Arg+checkArg arg = do+  argt <- checkSubExp arg+  als <- subExpAliasesM arg+  return (argt, als)++checkFuncall ::+  Maybe Name ->+  [DeclType] ->+  [Arg] ->+  TypeM rep ()+checkFuncall fname paramts args = do+  let argts = map argType args+  unless (validApply paramts argts) $+    bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args+  consumeArgs paramts args++consumeArgs ::+  [DeclType] ->+  [Arg] ->+  TypeM rep ()+consumeArgs paramts args =+  forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->+    occur [consumption (consumeArg als d)]+  where+    consumeArg als Consume = als+    consumeArg _ _ = mempty++-- The boolean indicates whether we only allow consumption of+-- parameters.+checkAnyLambda ::+  Checkable rep => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep ()+checkAnyLambda soac (Lambda params body rettype) args = do+  let fname = nameFromString "<anonymous>"+  if length params == length args+    then do+      -- Consumption for this is done explicitly elsewhere.+      checkFuncall+        Nothing+        (map ((`toDecl` Nonunique) . paramType) params)+        $ map noArgAliases args+      let consumable =+            if soac+              then Just $ zip (map paramName params) (map argAliases args)+              else Nothing+      checkFun'+        ( fname,+          staticShapes $ map (`toDecl` Nonunique) rettype,+          [ ( paramName param,+              LParamName $ paramDec param+            )+            | param <- params+          ]+        )+        consumable+        $ do+          checkLambdaParams params+          mapM_ checkType rettype+          checkLambdaBody rettype body+    else+      bad $+        TypeError $+          "Anonymous function defined with " ++ show (length params) ++ " parameters:\n"+            ++ pretty params+            ++ "\nbut expected to take "+            ++ show (length args)+            ++ " arguments."++checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep ()+checkLambda = checkAnyLambda True++checkPrimExp :: Checkable rep => PrimExp VName -> TypeM rep ()+checkPrimExp ValueExp {} = return ()+checkPrimExp (LeafExp v pt) = requireI [Prim pt] v+checkPrimExp (BinOpExp op x y) = do+  requirePrimExp (binOpType op) x+  requirePrimExp (binOpType op) y+checkPrimExp (CmpOpExp op x y) = do+  requirePrimExp (cmpOpType op) x+  requirePrimExp (cmpOpType op) y+checkPrimExp (UnOpExp op x) = requirePrimExp (unOpType op) x+checkPrimExp (ConvOpExp op x) = requirePrimExp (fst $ convOpType op) x+checkPrimExp (FunExp h args t) = do+  (h_ts, h_ret, _) <-+    maybe+      (bad $ TypeError $ "Unknown function: " ++ h)+      return+      $ M.lookup h primFuns+  when (length h_ts /= length args) $+    bad $+      TypeError $+        "Function expects " ++ show (length h_ts)+          ++ " parameters, but given "+          ++ show (length args)+          ++ " arguments."+  when (h_ret /= t) $+    bad $+      TypeError $+        "Function return annotation is " ++ pretty t+          ++ ", but expected "+          ++ pretty h_ret+  zipWithM_ requirePrimExp h_ts args++requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep ()+requirePrimExp t e = context ("in PrimExp " ++ pretty e) $ do+  checkPrimExp e+  unless (primExpType e == t) $+    bad $+      TypeError $+        pretty e ++ " must have type " ++ pretty t++class ASTRep rep => CheckableOp rep where+  checkOp :: OpWithAliases (Op rep) -> TypeM rep ()+  -- ^ Used at top level; can be locally changed with 'checkOpWith'.++-- | The class of representations that can be type-checked.+class (ASTRep rep, CanBeAliased (Op rep), CheckableOp rep) => Checkable rep where+  checkExpDec :: ExpDec rep -> TypeM rep ()+  checkBodyDec :: BodyDec rep -> TypeM rep ()+  checkFParamDec :: VName -> FParamInfo rep -> TypeM rep ()+  checkLParamDec :: VName -> LParamInfo rep -> TypeM rep ()+  checkLetBoundDec :: VName -> LetDec rep -> TypeM rep ()+  checkRetType :: [RetType rep] -> TypeM rep ()+  matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()+  primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep))+  matchReturnType :: [RetType rep] -> Result -> TypeM rep ()+  matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()+  matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep ()++  default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep ()+  checkExpDec = return++  default checkBodyDec :: BodyDec rep ~ () => BodyDec rep -> TypeM rep ()+  checkBodyDec = return++  default checkFParamDec :: FParamInfo rep ~ DeclType => VName -> FParamInfo rep -> TypeM rep ()+  checkFParamDec _ = checkType++  default checkLParamDec :: LParamInfo rep ~ Type => VName -> LParamInfo rep -> TypeM rep ()+  checkLParamDec _ = checkType++  default checkLetBoundDec :: LetDec rep ~ Type => VName -> LetDec rep -> TypeM rep ()+  checkLetBoundDec _ = checkType++  default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep ()+  checkRetType = mapM_ $ checkExtType . declExtTypeOf++  default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()+  matchPat pat = matchExtPat pat <=< expExtType++  default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))+  primFParam name t = return $ Param mempty name (Prim t)++  default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep ()+  matchReturnType = matchExtReturnType . map fromDecl++  default matchBranchType :: BranchType rep ~ ExtType => [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()+  matchBranchType = matchExtBranchType++  default matchLoopResult ::+    FParamInfo rep ~ DeclType =>+    [FParam (Aliases rep)] ->+    Result ->+    TypeM rep ()+  matchLoopResult = matchLoopResultExt

@@ -1136,6 +1136,7 @@   letValExp' desc . I.Op =<< f w lam' nes' arrs  internaliseHist ::+  Int ->   String ->   E.Exp ->   E.Exp ->@@ -1145,13 +1146,11 @@   E.Exp ->   SrcLoc ->   InternaliseM [SubExp]-internaliseHist desc rf hist op ne buckets img loc = do+internaliseHist dim desc rf hist op ne buckets img loc = do   rf' <- internaliseExp1 "hist_rf" rf   ne' <- internaliseExp "hist_ne" ne   hist' <- internaliseExpToVars "hist_hist" hist-  buckets' <--    letExp "hist_buckets" . BasicOp . SubExp-      =<< internaliseExp1 "hist_buckets" buckets+  buckets' <- internaliseExpToVars "hist_buckets" buckets   img' <- internaliseExpToVars "hist_img" img    -- reshape neutral element to have same size as the destination array@@ -1164,15 +1163,15 @@       "hist_ne_right_shape"       n   ne_ts <- mapM I.subExpType ne_shp-  his_ts <- mapM lookupType hist'+  his_ts <- mapM (fmap (I.stripArray (dim -1)) . lookupType) hist'   op' <- internaliseFoldLambda internaliseLambda op ne_ts his_ts    -- reshape return type of bucket function to have same size as neutral element   -- (modulo the index)-  bucket_param <- newParam "bucket_p" $ I.Prim int64+  bucket_params <- replicateM dim (newParam "bucket_p" $ I.Prim int64)   img_params <- mapM (newParam "img_p" . rowType) =<< mapM lookupType img'-  let params = bucket_param : img_params-      rettype = I.Prim int64 : ne_ts+  let params = bucket_params ++ img_params+      rettype = replicate dim (I.Prim int64) ++ ne_ts       body = mkBody mempty $ varsRes $ map paramName params   lam' <-     mkLambda params $@@ -1183,26 +1182,11 @@         =<< bodyBind body    -- get sizes of histogram and image arrays-  w_hist <- arraysSize 0 <$> mapM lookupType hist'-  w_img <- arraysSize 0 <$> mapM lookupType img'--  -- Generate an assertion and reshapes to ensure that buckets' and-  -- img' are the same size.-  b_shape <- I.arrayShape <$> lookupType buckets'-  let b_w = shapeSize 0 b_shape-  cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int64) b_w w_img-  c <--    assert-      "bucket_cert"-      cmp-      "length of index and value array does not match"-      loc-  buckets'' <--    certifying c . letExp (baseString buckets') $-      I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets'+  shape_hist <- Shape . take dim . I.arrayDims <$> lookupType (head hist')+  w_img <- I.arraySize 0 <$> lookupType (head img')    letValExp' desc . I.Op $-    I.Hist w_img (buckets'' : img') [HistOp w_hist rf' hist' ne_shp op'] lam'+    I.Hist w_img (buckets' ++ img') [HistOp shape_hist rf' hist' ne_shp op'] lam'  internaliseStreamMap ::   String ->@@ -1723,8 +1707,12 @@       internaliseStreamMap desc InOrder f arr     handleSOACs [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->       internaliseStreamMap desc Disorder f arr-    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->-      internaliseHist desc rf dest op ne buckets img loc+    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_1d" = Just $ \desc ->+      internaliseHist 1 desc rf dest op ne buckets img loc+    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_2d" = Just $ \desc ->+      internaliseHist 2 desc rf dest op ne buckets img loc+    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_3d" = Just $ \desc ->+      internaliseHist 3 desc rf dest op ne buckets img loc     handleSOACs _ _ = Nothing      handleAccs [TupLit [dest, f, bs] _] "scatter_stream" = Just $ \desc ->

@@ -277,6 +277,7 @@         -- memory block?         [arr_param] <- filter (isArrayIn (paramName param)) $ map fst merge,         MemArray pt _ _ (ArrayIn _ ixfun) <- paramDec arr_param,+        not $ merge_bound `namesIntersect` freeIn (IxFun.base ixfun),         Var res_v <- resSubExp res,         Just (res_v_alloc, body_stms'') <- extractAllocOf merge_bound res_v body_stms' = do         num_bytes <-

@@ -1,6 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}  -- | This module implements an optimization that tries to statically reuse@@ -9,7 +8,6 @@ module Futhark.Optimise.MemoryBlockMerging (optimise) where  import Control.Exception-import Control.Monad.Reader import Control.Monad.State.Strict import Data.Function ((&)) import Data.Map (Map, (!))@@ -17,7 +15,6 @@ import Data.Set (Set) import qualified Data.Set as S import qualified Futhark.Analysis.Interference as Interference-import qualified Futhark.Analysis.LastUse as LastUse import Futhark.Builder.Class import Futhark.Construct import Futhark.IR.GPUMem@@ -100,34 +97,8 @@       return s     helper [] = error "impossible" -definedInExp :: Exp GPUMem -> Set VName-definedInExp (Op (Inner (SegOp segop))) =-  definedInSegOp segop-definedInExp (If _ then_body else_body _) =-  foldMap definedInStm (bodyStms then_body)-    <> foldMap definedInStm (bodyStms else_body)-definedInExp (DoLoop _ _ body) =-  foldMap definedInStm $ bodyStms body-definedInExp _ = mempty--definedInStm :: Stm GPUMem -> Set VName-definedInStm Let {stmPat = Pat merge, stmExp} =-  let definedInside = merge & fmap patElemName & S.fromList-   in definedInExp stmExp <> definedInside--definedInSegOp :: SegOp lvl GPUMem -> Set VName-definedInSegOp (SegMap _ _ _ body) =-  foldMap definedInStm $ kernelBodyStms body-definedInSegOp (SegRed _ _ _ _ body) =-  foldMap definedInStm $ kernelBodyStms body-definedInSegOp (SegScan _ _ _ _ body) =-  foldMap definedInStm $ kernelBodyStms body-definedInSegOp (SegHist _ _ _ _ body) =-  foldMap definedInStm $ kernelBodyStms body--isKernelInvariant :: SegOp lvl GPUMem -> (SubExp, space) -> Bool-isKernelInvariant segop (Var vname, _) =-  not $ vname `S.member` definedInSegOp segop+isKernelInvariant :: Scope GPUMem -> (SubExp, space) -> Bool+isKernelInvariant scope (Var vname, _) = vname `M.member` scope isKernelInvariant _ _ = True  onKernelBodyStms ::@@ -158,7 +129,8 @@   m (SegOp lvl GPUMem) optimiseKernel graph segop0 = do   segop <- onKernelBodyStms segop0 $ onKernels $ optimiseKernel graph-  let allocs = M.filter (isKernelInvariant segop) $ getAllocsSegOp segop+  scope_here <- askScope+  let allocs = M.filter (isKernelInvariant scope_here) $ getAllocsSegOp segop       (colorspaces, coloring) =         GreedyColoring.colorGraph           (fmap snd allocs)@@ -194,48 +166,33 @@   (SegOp SegLevel GPUMem -> m (SegOp SegLevel GPUMem)) ->   Stms GPUMem ->   m (Stms GPUMem)-onKernels f =-  mapM helper+onKernels f stms = inScopeOf stms $ mapM helper stms   where-    helper stm@Let {stmExp = Op (Inner (SegOp segop))} =-      inScopeOf stm $ do-        exp' <- f segop-        return $ stm {stmExp = Op $ Inner $ SegOp exp'}-    helper stm@Let {stmExp = If c then_body else_body dec} =-      inScopeOf stm $ do-        then_body_stms <- f `onKernels` bodyStms then_body-        else_body_stms <- f `onKernels` bodyStms else_body-        return $-          stm-            { stmExp =-                If-                  c-                  (then_body {bodyStms = then_body_stms})-                  (else_body {bodyStms = else_body_stms})-                  dec-            }-    helper stm@Let {stmExp = DoLoop merge form body} =-      inScopeOf stm $ do-        stms <- f `onKernels` bodyStms body-        return $ stm {stmExp = DoLoop merge form (body {bodyStms = stms})}-    helper stm =-      inScopeOf stm $ return stm+    helper stm@Let {stmExp = Op (Inner (SegOp segop))} = do+      exp' <- f segop+      return $ stm {stmExp = Op $ Inner $ SegOp exp'}+    helper stm@Let {stmExp = If c then_body else_body dec} = do+      then_body_stms <- f `onKernels` bodyStms then_body+      else_body_stms <- f `onKernels` bodyStms else_body+      return $+        stm+          { stmExp =+              If+                c+                (then_body {bodyStms = then_body_stms})+                (else_body {bodyStms = else_body_stms})+                dec+          }+    helper stm@Let {stmExp = DoLoop merge form body} = do+      body_stms <- f `onKernels` bodyStms body+      return $ stm {stmExp = DoLoop merge form (body {bodyStms = body_stms})}+    helper stm = return stm  -- | Perform the reuse-allocations optimization. optimise :: Pass GPUMem GPUMem optimise =   Pass "reuse allocations" "reuse allocations" $ \prog ->-    let (lumap, _) = LastUse.analyseProg prog-        graph =-          foldMap-            ( \f ->-                runReader-                  ( Interference.analyseGPU lumap $-                      bodyStms $ funDefBody f-                  )-                  $ scopeOf f-            )-            $ progFuns prog+    let graph = Interference.analyseProgGPU prog      in Pass.intraproceduralTransformation (onStms graph) prog   where     onStms ::

@@ -45,7 +45,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer-import Data.List (foldl', partition, zip4)+import Data.List (foldl', partition, zip5) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S@@ -902,14 +902,6 @@ subExpIxFun Constant {} = return Nothing subExpIxFun (Var v) = lookupIxFun v -shiftShapeExts :: Int -> MemInfo ExtSize u r -> MemInfo ExtSize u r-shiftShapeExts k (MemArray pt shape u returns) =-  MemArray pt (fmap shift shape) u returns-  where-    shift (Ext i) = Ext (i + k)-    shift (Free x) = Free x-shiftShapeExts _ ret = ret- addResCtxInIfBody ::   (Allocable fromrep torep inner) =>   [ExtType] ->@@ -919,69 +911,72 @@   AllocM fromrep torep (Body torep, [BodyReturns]) addResCtxInIfBody ifrets (Body _ stms res) spaces substs = buildBody $ do   mapM_ addStm stms-  (ctx, ctx_rets, res', res_rets, total_existentials) <--    foldM helper ([], [], [], [], 0) (zip4 ifrets res substs spaces)-  pure-    ( ctx <> res',-      -- We need to adjust the existentials in shapes corresponding-      -- to the previous type, because we added more existentials in-      -- front.-      ctx_rets ++ map (shiftShapeExts total_existentials) res_rets-    )+  let offsets = scanl (+) 0 $ zipWith numCtxNeeded ifrets substs+      num_new_ctx = last offsets+  (ctx, ctx_rets, res', res_rets) <-+    foldM (helper num_new_ctx) ([], [], [], []) $+      zip5 ifrets res substs spaces offsets+  pure (ctx <> res', ctx_rets ++ res_rets)   where-    helper (ctx_acc, ctx_rets_acc, res_acc, res_rets_acc, k) (ifr, r, mbixfsub, sp) =-      case mbixfsub of-        Nothing -> do-          -- does NOT generalize/antiunify; ensure direct-          r' <- ensureDirect sp r-          (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r'-          let body_ret = inspect k ifr sp-          pure-            ( ctx_acc ++ mem_ctx_ses,-              ctx_rets_acc ++ mem_ctx_rets,-              res_acc ++ [r'],-              res_rets_acc ++ [body_ret],-              k + length mem_ctx_ses-            )-        Just (ixfn, m) -> do-          -- generalizes-          let i = length m-          ext_ses <- mapM (toSubExp "ixfn_exist") m-          (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r-          let sp' = fromMaybe DefaultSpace sp-              ixfn' = fmap (adjustExtPE k) ixfn-              exttp = case ifr of-                Array pt shp' u ->-                  MemArray pt shp' u $ ReturnsNewBlock sp' (k + i) ixfn'-                _ -> error "Impossible case reached in addResCtxInIfBody"-          pure-            ( ctx_acc ++ subExpsRes ext_ses ++ mem_ctx_ses,-              ctx_rets_acc ++ map (const (MemPrim int64)) ext_ses ++ mem_ctx_rets,-              res_acc ++ [r],-              res_rets_acc ++ [exttp],-              k + i + 1-            )+    numCtxNeeded Array {} Nothing = 1+    numCtxNeeded Array {} (Just (_, m)) = length m + 1+    numCtxNeeded _ _ = 0 -    inspect k (Array pt shape u) space =+    helper+      num_new_ctx+      (ctx_acc, ctx_rets_acc, res_acc, res_rets_acc)+      (ifr, r, mbixfsub, sp, ctx_offset) =+        case mbixfsub of+          Nothing -> do+            -- does NOT generalize/antiunify; ensure direct+            r' <- ensureDirect sp r+            (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r'+            let body_ret = inspect num_new_ctx ctx_offset ifr sp+            pure+              ( ctx_acc ++ mem_ctx_ses,+                ctx_rets_acc ++ mem_ctx_rets,+                res_acc ++ [r'],+                res_rets_acc ++ [body_ret]+              )+          Just (ixfn, m) -> do+            -- generalizes+            let i = length m+            ext_ses <- mapM (toSubExp "ixfn_exist") m+            (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r+            let sp' = fromMaybe DefaultSpace sp+                ixfn' = fmap (adjustExtPE ctx_offset) ixfn+                exttp = case ifr of+                  Array pt shape u ->+                    MemArray pt (fmap (adjustExt num_new_ctx) shape) u $+                      ReturnsNewBlock sp' (ctx_offset + i) ixfn'+                  _ -> error "Impossible case reached in addResCtxInIfBody"+            pure+              ( ctx_acc ++ subExpsRes ext_ses ++ mem_ctx_ses,+                ctx_rets_acc ++ map (const (MemPrim int64)) ext_ses ++ mem_ctx_rets,+                res_acc ++ [r],+                res_rets_acc ++ [exttp]+              )++    inspect num_new_ctx k (Array pt shape u) space =       let space' = fromMaybe DefaultSpace space+          shape' = fmap (adjustExt num_new_ctx) shape           bodyret =-            MemArray pt shape u $-              ReturnsNewBlock space' k $-                IxFun.iota $ map convert $ shapeDims shape+            MemArray pt shape' u . ReturnsNewBlock space' k $+              IxFun.iota $ map convert $ shapeDims shape'        in bodyret-    inspect _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u-    inspect _ (Prim pt) _ = MemPrim pt-    inspect _ (Mem space) _ = MemMem space+    inspect _ _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u+    inspect _ _ (Prim pt) _ = MemPrim pt+    inspect _ _ (Mem space) _ = MemMem space      convert (Ext i) = le64 (Ext i)     convert (Free v) = Free <$> pe64 v -    adjustExtV :: Int -> Ext VName -> Ext VName-    adjustExtV _ (Free v) = Free v-    adjustExtV k (Ext i) = Ext (k + i)+    adjustExt :: Int -> Ext a -> Ext a+    adjustExt _ (Free v) = Free v+    adjustExt k (Ext i) = Ext (k + i)      adjustExtPE :: Int -> TPrimExp t (Ext VName) -> TPrimExp t (Ext VName)-    adjustExtPE k = fmap (adjustExtV k)+    adjustExtPE k = fmap (adjustExt k)  mkSpaceOks ::   (Mem torep inner, LocalScope torep m) =>

@@ -974,10 +974,10 @@   [VName] ->   m (Stms (Rep m)) histKernel onLambda lvl orig_pat ispace inputs cs hist_w ops lam arrs = runBuilderT'_ $ do-  ops' <- forM ops $ \(SOACS.HistOp num_bins rf dests nes op) -> do+  ops' <- forM ops $ \(SOACS.HistOp dest_shape rf dests nes op) -> do     (op', nes', shape) <- determineReduceOp op nes     op'' <- lift $ onLambda op'-    return $ HistOp num_bins rf dests nes' shape op''+    return $ HistOp dest_shape rf dests nes' shape op''    let isDest = flip elem $ concatMap histDest ops'       inputs' = filter (not . isDest . kernelInputArray) inputs

@@ -90,7 +90,6 @@     >>> onePass Seq.explicitAllocations     >>> passes       [ performCSE False,-        simplifySeqMem,         simplifySeqMem       ] 

@@ -38,9 +38,9 @@ import qualified Futhark.Analysis.Alias as Alias import Futhark.Error import Futhark.IR (PrettyRep, Prog)+import Futhark.IR.TypeCheck import Futhark.MonadFreshNames import Futhark.Pass-import Futhark.TypeCheck import Futhark.Util.Log import Futhark.Util.Pretty (prettyText) import System.IO

@@ -317,36 +317,35 @@     imgs'' <- map resSubExp <$> bindLambda bucket_fun (map (BasicOp . SubExp) imgs')      -- Split out values from bucket function.-    let lens = length ops-        inds = take lens imgs''+    let lens = sum $ map (shapeRank . histShape) ops+        ops_inds = chunks (map (shapeRank . histShape) ops) (take lens imgs'')         vals = chunks (map (length . lambdaReturnType . histOp) ops) $ drop lens imgs''         hists_out' =           chunks (map (length . lambdaReturnType . histOp) ops) $             map identName hists_out -    hists_out'' <- forM (zip4 hists_out' ops inds vals) $ \(hist, op, idx, val) -> do+    hists_out'' <- forM (zip4 hists_out' ops ops_inds vals) $ \(hist, op, idxs, val) -> do       -- Check whether the indexes are in-bound.  If they are not, we       -- return the histograms unchanged.       let outside_bounds_branch = buildBody_ $ pure $ varsRes hist           oob = case hist of             [] -> eSubExp $ constant True-            arr : _ -> eOutOfBounds arr [eSubExp idx]+            arr : _ -> eOutOfBounds arr $ map eSubExp idxs        letTupExp "new_histo" <=< eIf oob outside_bounds_branch $         buildBody_ $ do           -- Read values from histogram.           h_val <- forM hist $ \arr -> do             arr_t <- lookupType arr-            letSubExp "read_hist" $ BasicOp $ Index arr $ fullSlice arr_t [DimFix idx]+            letSubExp "read_hist" $ BasicOp $ Index arr $ fullSlice arr_t $ map DimFix idxs            -- Apply operator.-          h_val' <--            bindLambda (histOp op) $ map (BasicOp . SubExp) $ h_val ++ val+          h_val' <- bindLambda (histOp op) $ map (BasicOp . SubExp) $ h_val ++ val            -- Write values back to histograms.           hist' <- forM (zip hist h_val') $ \(arr, SubExpRes cs v) -> do             arr_t <- lookupType arr-            certifying cs . letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $+            certifying cs . letInPlace "hist_out" arr (fullSlice arr_t $ map DimFix idxs) $               BasicOp $ SubExp v            pure $ varsRes hist'

@@ -1,1534 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}---- | The type checker checks whether the program is type-consistent.-module Futhark.TypeCheck-  ( -- * Interface-    checkProg,-    TypeError (..),-    ErrorCase (..),--    -- * Extensionality-    TypeM,-    bad,-    context,-    message,-    Checkable (..),-    CheckableOp (..),-    lookupVar,-    lookupAliases,-    checkOpWith,--    -- * Checkers-    require,-    requireI,-    requirePrimExp,-    checkSubExp,-    checkCerts,-    checkExp,-    checkStms,-    checkStm,-    checkType,-    checkExtType,-    matchExtPat,-    matchExtBranchType,-    argType,-    argAliases,-    noArgAliases,-    checkArg,-    checkSOACArrayArgs,-    checkLambda,-    checkBody,-    consume,-    consumeOnlyParams,-    binding,-    alternative,-  )-where--import Control.Monad.Reader-import Control.Monad.State.Strict-import Control.Parallel.Strategies-import Data.Bifunctor (second)-import Data.List (find, intercalate, isPrefixOf, sort)-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Set as S-import Futhark.Analysis.PrimExp-import Futhark.Construct (instantiateShapes)-import Futhark.IR.Aliases hiding (lookupAliases)-import Futhark.Util-import Futhark.Util.Pretty (Pretty, align, indent, ppr, prettyDoc, text, (<+>), (</>))---- | Information about an error during type checking.  The 'Show'--- instance for this type produces a human-readable description.-data ErrorCase rep-  = TypeError String-  | UnexpectedType (Exp rep) Type [Type]-  | ReturnTypeError Name [ExtType] [ExtType]-  | DupDefinitionError Name-  | DupParamError Name VName-  | DupPatError VName-  | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String)-  | UnknownVariableError VName-  | UnknownFunctionError Name-  | ParameterMismatch (Maybe Name) [Type] [Type]-  | SlicingError Int Int-  | BadAnnotation String Type Type-  | ReturnAliased Name VName-  | UniqueReturnAliased Name-  | NotAnArray VName Type-  | PermutationError [Int] Int (Maybe VName)--instance Checkable rep => Show (ErrorCase rep) where-  show (TypeError msg) =-    "Type error:\n" ++ msg-  show (UnexpectedType e _ []) =-    "Type of expression\n"-      ++ prettyDoc 160 (indent 2 $ ppr e)-      ++ "\ncannot have any type - possibly a bug in the type checker."-  show (UnexpectedType e t ts) =-    "Type of expression\n"-      ++ prettyDoc 160 (indent 2 $ ppr e)-      ++ "\nmust be one of "-      ++ intercalate ", " (map pretty ts)-      ++ ", but is "-      ++ pretty t-      ++ "."-  show (ReturnTypeError fname rettype bodytype) =-    "Declaration of function " ++ nameToString fname-      ++ " declares return type\n  "-      ++ prettyTuple rettype-      ++ "\nBut body has type\n  "-      ++ prettyTuple bodytype-  show (DupDefinitionError name) =-    "Duplicate definition of function " ++ nameToString name ++ ""-  show (DupParamError funname paramname) =-    "Parameter " ++ pretty paramname-      ++ " mentioned multiple times in argument list of function "-      ++ nameToString funname-      ++ "."-  show (DupPatError name) =-    "Variable " ++ pretty name ++ " bound twice in pattern."-  show (InvalidPatError pat t desc) =-    "Pat\n" ++ pretty pat-      ++ "\ncannot match value of type\n"-      ++ prettyTupleLines t-      ++ end-    where-      end = case desc of-        Nothing -> "."-        Just desc' -> ":\n" ++ desc'-  show (UnknownVariableError name) =-    "Use of unknown variable " ++ pretty name ++ "."-  show (UnknownFunctionError fname) =-    "Call of unknown function " ++ nameToString fname ++ "."-  show (ParameterMismatch fname expected got) =-    "In call of " ++ fname' ++ ":\n"-      ++ "expecting "-      ++ show nexpected-      ++ " arguments of type(s)\n"-      ++ intercalate ", " (map pretty expected)-      ++ "\nGot "-      ++ show ngot-      ++ " arguments of types\n"-      ++ intercalate ", " (map pretty got)-    where-      nexpected = length expected-      ngot = length got-      fname' = maybe "anonymous function" (("function " ++) . nameToString) fname-  show (SlicingError dims got) =-    show got ++ " indices given, but type of indexee has " ++ show dims ++ " dimension(s)."-  show (BadAnnotation desc expected got) =-    "Annotation of \"" ++ desc ++ "\" type of expression is " ++ pretty expected-      ++ ", but derived to be "-      ++ pretty got-      ++ "."-  show (ReturnAliased fname name) =-    "Unique return value of function " ++ nameToString fname-      ++ " is aliased to "-      ++ pretty name-      ++ ", which is not consumed."-  show (UniqueReturnAliased fname) =-    "A unique tuple element of return value of function "-      ++ nameToString fname-      ++ " is aliased to some other tuple component."-  show (NotAnArray e t) =-    "The expression " ++ pretty e-      ++ " is expected to be an array, but is "-      ++ pretty t-      ++ "."-  show (PermutationError perm rank name) =-    "The permutation (" ++ intercalate ", " (map show perm)-      ++ ") is not valid for array "-      ++ name'-      ++ "of rank "-      ++ show rank-      ++ "."-    where-      name' = maybe "" ((++ " ") . pretty) name---- | A type error.-data TypeError rep = Error [String] (ErrorCase rep)--instance Checkable rep => Show (TypeError rep) where-  show (Error [] err) =-    show err-  show (Error msgs err) =-    intercalate "\n" msgs ++ "\n" ++ show err---- | A tuple of a return type and a list of parameters, possibly--- named.-type FunBinding rep = ([RetType (Aliases rep)], [FParam (Aliases rep)])--type VarBinding rep = NameInfo (Aliases rep)--data Usage-  = Consumed-  | Observed-  deriving (Eq, Ord, Show)--data Occurence = Occurence-  { observed :: Names,-    consumed :: Names-  }-  deriving (Eq, Show)--observation :: Names -> Occurence-observation = flip Occurence mempty--consumption :: Names -> Occurence-consumption = Occurence mempty--nullOccurence :: Occurence -> Bool-nullOccurence occ = observed occ == mempty && consumed occ == mempty--type Occurences = [Occurence]--allConsumed :: Occurences -> Names-allConsumed = mconcat . map consumed--seqOccurences :: Occurences -> Occurences -> Occurences-seqOccurences occurs1 occurs2 =-  filter (not . nullOccurence) (map filt occurs1) ++ occurs2-  where-    filt occ =-      occ {observed = observed occ `namesSubtract` postcons}-    postcons = allConsumed occurs2--altOccurences :: Occurences -> Occurences -> Occurences-altOccurences occurs1 occurs2 =-  filter (not . nullOccurence) (map filt occurs1) ++ occurs2-  where-    filt occ =-      occ-        { consumed = consumed occ `namesSubtract` postcons,-          observed = observed occ `namesSubtract` postcons-        }-    postcons = allConsumed occurs2--unOccur :: Names -> Occurences -> Occurences-unOccur to_be_removed = filter (not . nullOccurence) . map unOccur'-  where-    unOccur' occ =-      occ-        { observed = observed occ `namesSubtract` to_be_removed,-          consumed = consumed occ `namesSubtract` to_be_removed-        }---- | The 'Consumption' data structure is used to keep track of which--- variables have been consumed, as well as whether a violation has been detected.-data Consumption-  = ConsumptionError String-  | Consumption Occurences-  deriving (Show)--instance Semigroup Consumption where-  ConsumptionError e <> _ = ConsumptionError e-  _ <> ConsumptionError e = ConsumptionError e-  Consumption o1 <> Consumption o2-    | v : _ <- namesToList $ consumed_in_o1 `namesIntersection` used_in_o2 =-      ConsumptionError $ "Variable " <> pretty v <> " referenced after being consumed."-    | otherwise =-      Consumption $ o1 `seqOccurences` o2-    where-      consumed_in_o1 = mconcat $ map consumed o1-      used_in_o2 = mconcat $ map consumed o2 <> map observed o2--instance Monoid Consumption where-  mempty = Consumption mempty---- | The environment contains a variable table and a function table.--- Type checking happens with access to this environment.  The--- function table is only initialised at the very beginning, but the--- variable table will be extended during type-checking when--- let-expressions are encountered.-data Env rep = Env-  { envVtable :: M.Map VName (VarBinding rep),-    envFtable :: M.Map Name (FunBinding rep),-    envCheckOp :: OpWithAliases (Op rep) -> TypeM rep (),-    envContext :: [String]-  }--data TState = TState-  { stateNames :: Names,-    stateCons :: Consumption-  }---- | The type checker runs in this monad.-newtype TypeM rep a-  = TypeM-      ( ReaderT-          (Env rep)-          (StateT TState (Either (TypeError rep)))-          a-      )-  deriving-    ( Monad,-      Functor,-      Applicative,-      MonadReader (Env rep),-      MonadState TState-    )--instance-  Checkable rep =>-  HasScope (Aliases rep) (TypeM rep)-  where-  lookupType = fmap typeOf . lookupVar-  askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable-    where-      varType (name, dec) = Just (name, dec)--runTypeM ::-  Env rep ->-  TypeM rep a ->-  Either (TypeError rep) (a, Consumption)-runTypeM env (TypeM m) =-  second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty)--bad :: ErrorCase rep -> TypeM rep a-bad e = do-  messages <- asks envContext-  TypeM $ lift $ lift $ Left $ Error (reverse messages) e--tell :: Consumption -> TypeM rep ()-tell cons = modify $ \s -> s {stateCons = stateCons s <> cons}---- | Add information about what is being type-checked to the current--- context.  Liberal use of this combinator makes it easier to track--- type errors, as the strings are added to type errors signalled via--- 'bad'.-context ::-  String ->-  TypeM rep a ->-  TypeM rep a-context s = local $ \env -> env {envContext = s : envContext env}--message ::-  Pretty a =>-  String ->-  a ->-  String-message s x =-  prettyDoc 80 $-    text s <+> align (ppr x)---- | Mark a name as bound.  If the name has been bound previously in--- the program, report a type error.-bound :: VName -> TypeM rep ()-bound name = do-  already_seen <- gets $ nameIn name . stateNames-  when already_seen $-    bad $ TypeError $ "Name " ++ pretty name ++ " bound twice"-  modify $ \s -> s {stateNames = oneName name <> stateNames s}--occur :: Occurences -> TypeM rep ()-occur = tell . Consumption . filter (not . nullOccurence)---- | Proclaim that we have made read-only use of the given variable.--- No-op unless the variable is array-typed.-observe ::-  Checkable rep =>-  VName ->-  TypeM rep ()-observe name = do-  dec <- lookupVar name-  unless (primType $ typeOf dec) $-    occur [observation $ oneName name <> aliases dec]---- | Proclaim that we have written to the given variables.-consume :: Checkable rep => Names -> TypeM rep ()-consume als = do-  scope <- askScope-  let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope)-  occur [consumption $ namesFromList $ filter isArray $ namesToList als]--collectOccurences :: TypeM rep a -> TypeM rep (a, Occurences)-collectOccurences m = do-  old <- gets stateCons-  modify $ \s -> s {stateCons = mempty}-  x <- m-  new <- gets stateCons-  modify $ \s -> s {stateCons = old}-  o <- checkConsumption new-  pure (x, o)--checkOpWith ::-  (OpWithAliases (Op rep) -> TypeM rep ()) ->-  TypeM rep a ->-  TypeM rep a-checkOpWith checker = local $ \env -> env {envCheckOp = checker}--checkConsumption :: Consumption -> TypeM rep Occurences-checkConsumption (ConsumptionError e) = bad $ TypeError e-checkConsumption (Consumption os) = return os--alternative :: TypeM rep a -> TypeM rep b -> TypeM rep (a, b)-alternative m1 m2 = do-  (x, os1) <- collectOccurences m1-  (y, os2) <- collectOccurences m2-  tell $ Consumption $ os1 `altOccurences` os2-  pure (x, y)---- | Permit consumption of only the specified names.  If one of these--- names is consumed, the consumption will be rewritten to be a--- consumption of the corresponding alias set.  Consumption of--- anything else will result in a type error.-consumeOnlyParams :: [(VName, Names)] -> TypeM rep a -> TypeM rep a-consumeOnlyParams consumable m = do-  (x, os) <- collectOccurences m-  tell . Consumption =<< mapM inspect os-  return x-  where-    inspect o = do-      new_consumed <- mconcat <$> mapM wasConsumed (namesToList $ consumed o)-      return o {consumed = new_consumed}-    wasConsumed v-      | Just als <- lookup v consumable = return als-      | otherwise =-        bad $-          TypeError $-            unlines-              [ pretty v ++ " was invalidly consumed.",-                what ++ " can be consumed here."-              ]-    what-      | null consumable = "Nothing"-      | otherwise = "Only " ++ intercalate ", " (map (pretty . fst) consumable)---- | Given the immediate aliases, compute the full transitive alias--- set (including the immediate aliases).-expandAliases :: Names -> Env rep -> Names-expandAliases names env = names <> aliasesOfAliases-  where-    aliasesOfAliases = mconcat . map look . namesToList $ names-    look k = case M.lookup k $ envVtable env of-      Just (LetName (als, _)) -> unAliases als-      _ -> mempty--binding ::-  Checkable rep =>-  Scope (Aliases rep) ->-  TypeM rep a ->-  TypeM rep a-binding stms = check . local (`bindVars` stms)-  where-    bindVars = M.foldlWithKey' bindVar-    boundnames = M.keys stms--    bindVar env name (LetName (AliasDec als, dec)) =-      let als'-            | primType (typeOf dec) = mempty-            | otherwise = expandAliases als env-       in env-            { envVtable =-                M.insert name (LetName (AliasDec als', dec)) $ envVtable env-            }-    bindVar env name dec =-      env {envVtable = M.insert name dec $ envVtable env}--    -- Check whether the bound variables have been used correctly-    -- within their scope.-    check m = do-      mapM_ bound $ M.keys stms-      (a, os) <- collectOccurences m-      tell $ Consumption $ unOccur (namesFromList boundnames) os-      return a--lookupVar :: VName -> TypeM rep (NameInfo (Aliases rep))-lookupVar name = do-  stm <- asks $ M.lookup name . envVtable-  case stm of-    Nothing -> bad $ UnknownVariableError name-    Just dec -> return dec--lookupAliases :: Checkable rep => VName -> TypeM rep Names-lookupAliases name = do-  info <- lookupVar name-  return $-    if primType $ typeOf info-      then mempty-      else oneName name <> aliases info--aliases :: NameInfo (Aliases rep) -> Names-aliases (LetName (als, _)) = unAliases als-aliases _ = mempty--subExpAliasesM :: Checkable rep => SubExp -> TypeM rep Names-subExpAliasesM Constant {} = return mempty-subExpAliasesM (Var v) = lookupAliases v--lookupFun ::-  Checkable rep =>-  Name ->-  [SubExp] ->-  TypeM rep ([RetType rep], [DeclType])-lookupFun fname args = do-  stm <- asks $ M.lookup fname . envFtable-  case stm of-    Nothing -> bad $ UnknownFunctionError fname-    Just (ftype, params) -> do-      argts <- mapM subExpType args-      case applyRetType ftype params $ zip args argts of-        Nothing ->-          bad $ ParameterMismatch (Just fname) (map paramType params) argts-        Just rt ->-          return (rt, map paramDeclType params)---- | @checkAnnotation loc s t1 t2@ checks if @t2@ is equal to--- @t1@.  If not, a 'BadAnnotation' is raised.-checkAnnotation ::-  String ->-  Type ->-  Type ->-  TypeM rep ()-checkAnnotation desc t1 t2-  | t2 == t1 = return ()-  | otherwise = bad $ BadAnnotation desc t1 t2---- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is--- not a subtype of one of the types in @ts@.-require :: Checkable rep => [Type] -> SubExp -> TypeM rep ()-require ts se = do-  t <- checkSubExp se-  unless (t `elem` ts) $-    bad $ UnexpectedType (BasicOp $ SubExp se) t ts---- | Variant of 'require' working on variable names.-requireI :: Checkable rep => [Type] -> VName -> TypeM rep ()-requireI ts ident = require ts $ Var ident--checkArrIdent ::-  Checkable rep =>-  VName ->-  TypeM rep Type-checkArrIdent v = do-  t <- lookupType v-  case t of-    Array {} -> return t-    _ -> bad $ NotAnArray v t--checkAccIdent ::-  Checkable rep =>-  VName ->-  TypeM rep (Shape, [Type])-checkAccIdent v = do-  t <- lookupType v-  case t of-    Acc _ ispace ts _ ->-      pure (ispace, ts)-    _ ->-      bad . TypeError $-        pretty v-          ++ " should be an accumulator but is of type "-          ++ pretty t---- | Type check a program containing arbitrary type information,--- yielding either a type error or a program with complete type--- information.-checkProg ::-  Checkable rep =>-  Prog (Aliases rep) ->-  Either (TypeError rep) ()-checkProg (Prog consts funs) = do-  let typeenv =-        Env-          { envVtable = M.empty,-            envFtable = mempty,-            envContext = [],-            envCheckOp = checkOp-          }-  let onFunction ftable vtable fun =-        fmap fst $-          runTypeM typeenv $-            local (\env -> env {envFtable = ftable, envVtable = vtable}) $-              checkFun fun-  (ftable, _) <- runTypeM typeenv buildFtable-  (vtable, _) <--    runTypeM typeenv {envFtable = ftable} $-      checkStms consts $ asks envVtable-  sequence_ $ parMap rpar (onFunction ftable vtable) funs-  where-    buildFtable = do-      table <- initialFtable-      foldM expand table funs-    expand ftable (FunDef _ _ name ret params _)-      | M.member name ftable =-        bad $ DupDefinitionError name-      | otherwise =-        return $ M.insert name (ret, params) ftable--initialFtable ::-  Checkable rep =>-  TypeM rep (M.Map Name (FunBinding rep))-initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions-  where-    addBuiltin (fname, (t, ts)) = do-      ps <- mapM (primFParam name) ts-      return (fname, ([primRetType t], ps))-    name = VName (nameFromString "x") 0--checkFun ::-  Checkable rep =>-  FunDef (Aliases rep) ->-  TypeM rep ()-checkFun (FunDef _ _ fname rettype params body) =-  context ("In function " ++ nameToString fname) $-    checkFun'-      ( fname,-        map declExtTypeOf rettype,-        funParamsToNameInfos params-      )-      (Just consumable)-      $ do-        checkFunParams params-        checkRetType rettype-        context "When checking function body" $ checkFunBody rettype body-  where-    consumable =-      [ (paramName param, mempty)-        | param <- params,-          unique $ paramDeclType param-      ]--funParamsToNameInfos ::-  [FParam rep] ->-  [(VName, NameInfo (Aliases rep))]-funParamsToNameInfos = map nameTypeAndDec-  where-    nameTypeAndDec fparam =-      ( paramName fparam,-        FParamName $ paramDec fparam-      )--checkFunParams ::-  Checkable rep =>-  [FParam rep] ->-  TypeM rep ()-checkFunParams = mapM_ $ \param ->-  context ("In function parameter " ++ pretty param) $-    checkFParamDec (paramName param) (paramDec param)--checkLambdaParams ::-  Checkable rep =>-  [LParam rep] ->-  TypeM rep ()-checkLambdaParams = mapM_ $ \param ->-  context ("In lambda parameter " ++ pretty param) $-    checkLParamDec (paramName param) (paramDec param)--checkFun' ::-  Checkable rep =>-  ( Name,-    [DeclExtType],-    [(VName, NameInfo (Aliases rep))]-  ) ->-  Maybe [(VName, Names)] ->-  TypeM rep [Names] ->-  TypeM rep ()-checkFun' (fname, rettype, params) consumable check = do-  checkNoDuplicateParams-  binding (M.fromList params) $-    maybe id consumeOnlyParams consumable $ do-      body_aliases <- check-      scope <- askScope-      let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)-      context-        ( "When checking the body aliases: "-            ++ pretty (map namesToList body_aliases)-        )-        $ checkReturnAlias $ map (namesFromList . filter isArray . namesToList) body_aliases-  where-    param_names = map fst params--    checkNoDuplicateParams = foldM_ expand [] param_names--    expand seen pname-      | Just _ <- find (== pname) seen =-        bad $ DupParamError fname pname-      | otherwise =-        return $ pname : seen-    checkReturnAlias =-      foldM_ checkReturnAlias' mempty . returnAliasing rettype--    checkReturnAlias' seen (Unique, names)-      | any (`S.member` S.map fst seen) $ namesToList names =-        bad $ UniqueReturnAliased fname-      | otherwise = do-        consume names-        return $ seen <> tag Unique names-    checkReturnAlias' seen (Nonunique, names)-      | any (`S.member` seen) $ tag Unique names =-        bad $ UniqueReturnAliased fname-      | otherwise = return $ seen <> tag Nonunique names--    tag u = S.fromList . map (,u) . namesToList--    returnAliasing expected got =-      reverse $-        zip (reverse (map uniqueness expected) ++ repeat Nonunique) $-          reverse got--checkSubExp :: Checkable rep => SubExp -> TypeM rep Type-checkSubExp (Constant val) =-  return $ Prim $ primValueType val-checkSubExp (Var ident) = context ("In subexp " ++ pretty ident) $ do-  observe ident-  lookupType ident--checkCerts :: Checkable rep => Certs -> TypeM rep ()-checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs--checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type-checkSubExpRes (SubExpRes cs se) = do-  checkCerts cs-  checkSubExp se--checkStms ::-  Checkable rep =>-  Stms (Aliases rep) ->-  TypeM rep a ->-  TypeM rep a-checkStms origstms m = delve $ stmsToList origstms-  where-    delve (stm@(Let pat _ e) : stms) = do-      context (pretty $ "In expression of statement" </> indent 2 (ppr pat)) $-        checkExp e-      checkStm stm $-        delve stms-    delve [] =-      m--checkResult ::-  Checkable rep =>-  Result ->-  TypeM rep ()-checkResult = mapM_ checkSubExpRes--checkFunBody ::-  Checkable rep =>-  [RetType rep] ->-  Body (Aliases rep) ->-  TypeM rep [Names]-checkFunBody rt (Body (_, rep) stms res) = do-  checkBodyDec rep-  checkStms stms $ do-    context "When checking body result" $ checkResult res-    context "When matching declared return type to result of body" $-      matchReturnType rt res-    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res-  where-    bound_here = namesFromList $ M.keys $ scopeOf stms--checkLambdaBody ::-  Checkable rep =>-  [Type] ->-  Body (Aliases rep) ->-  TypeM rep [Names]-checkLambdaBody ret (Body (_, rep) stms res) = do-  checkBodyDec rep-  checkStms stms $ do-    checkLambdaResult ret res-    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res-  where-    bound_here = namesFromList $ M.keys $ scopeOf stms--checkLambdaResult ::-  Checkable rep =>-  [Type] ->-  Result ->-  TypeM rep ()-checkLambdaResult ts es-  | length ts /= length es =-    bad $-      TypeError $-        "Lambda has return type " ++ prettyTuple ts-          ++ " describing "-          ++ show (length ts)-          ++ " values, but body returns "-          ++ show (length es)-          ++ " values: "-          ++ prettyTuple es-  | otherwise = forM_ (zip ts es) $ \(t, e) -> do-    et <- checkSubExpRes e-    unless (et == t) $-      bad $-        TypeError $-          "Subexpression " ++ pretty e ++ " has type " ++ pretty et-            ++ " but expected "-            ++ pretty t--checkBody ::-  Checkable rep =>-  Body (Aliases rep) ->-  TypeM rep [Names]-checkBody (Body (_, rep) stms res) = do-  checkBodyDec rep-  checkStms stms $ do-    checkResult res-    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res-  where-    bound_here = namesFromList $ M.keys $ scopeOf stms--checkBasicOp :: Checkable rep => BasicOp -> TypeM rep ()-checkBasicOp (SubExp es) =-  void $ checkSubExp es-checkBasicOp (Opaque _ es) =-  void $ checkSubExp es-checkBasicOp (ArrayLit [] _) =-  return ()-checkBasicOp (ArrayLit (e : es') t) = do-  let check elemt eleme = do-        elemet <- checkSubExp eleme-        unless (elemet == elemt) $-          bad $-            TypeError $-              pretty elemet-                ++ " is not of expected type "-                ++ pretty elemt-                ++ "."-  et <- checkSubExp e--  -- Compare that type with the one given for the array literal.-  checkAnnotation "array-element" t et--  mapM_ (check et) es'-checkBasicOp (UnOp op e) = require [Prim $ unOpType op] e-checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2-checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2-checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e-checkBasicOp (Index ident (Slice idxes)) = do-  vt <- lookupType ident-  observe ident-  when (arrayRank vt /= length idxes) $-    bad $ SlicingError (arrayRank vt) (length idxes)-  mapM_ checkDimIndex idxes-checkBasicOp (Update _ src (Slice idxes) se) = do-  src_t <- checkArrIdent src-  when (arrayRank src_t /= length idxes) $-    bad $ SlicingError (arrayRank src_t) (length idxes)--  se_aliases <- subExpAliasesM se-  when (src `nameIn` se_aliases) $-    bad $ TypeError "The target of an Update must not alias the value to be written."--  mapM_ checkDimIndex idxes-  require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims (Slice idxes))) NoUniqueness] se-  consume =<< lookupAliases src-checkBasicOp (FlatIndex ident slice) = do-  vt <- lookupType ident-  observe ident-  when (arrayRank vt /= 1) $-    bad $ SlicingError (arrayRank vt) 1-  checkFlatSlice slice-checkBasicOp (FlatUpdate src slice v) = do-  src_t <- checkArrIdent src-  when (arrayRank src_t /= 1) $-    bad $ SlicingError (arrayRank src_t) 1--  v_aliases <- lookupAliases v-  when (src `nameIn` v_aliases) $-    bad $ TypeError "The target of an Update must not alias the value to be written."--  checkFlatSlice slice-  requireI [arrayOf (Prim (elemType src_t)) (Shape (flatSliceDims slice)) NoUniqueness] v-  consume =<< lookupAliases src-checkBasicOp (Iota e x s et) = do-  require [Prim int64] e-  require [Prim $ IntType et] x-  require [Prim $ IntType et] s-checkBasicOp (Replicate (Shape dims) valexp) = do-  mapM_ (require [Prim int64]) dims-  void $ checkSubExp valexp-checkBasicOp (Scratch _ shape) =-  mapM_ checkSubExp shape-checkBasicOp (Reshape newshape arrexp) = do-  rank <- arrayRank <$> checkArrIdent arrexp-  mapM_ (require [Prim int64] . newDim) newshape-  zipWithM_ (checkDimChange rank) newshape [0 ..]-  where-    checkDimChange _ (DimNew _) _ =-      return ()-    checkDimChange rank (DimCoercion se) i-      | i >= rank =-        bad $-          TypeError $-            "Asked to coerce dimension " ++ show i ++ " to " ++ pretty se-              ++ ", but array "-              ++ pretty arrexp-              ++ " has only "-              ++ pretty rank-              ++ " dimensions"-      | otherwise =-        return ()-checkBasicOp (Rearrange perm arr) = do-  arrt <- lookupType arr-  let rank = arrayRank arrt-  when (length perm /= rank || sort perm /= [0 .. rank -1]) $-    bad $ PermutationError perm rank $ Just arr-checkBasicOp (Rotate rots arr) = do-  arrt <- lookupType arr-  let rank = arrayRank arrt-  mapM_ (require [Prim int64]) rots-  when (length rots /= rank) $-    bad $-      TypeError $-        "Cannot rotate " ++ show (length rots)-          ++ " dimensions of "-          ++ show rank-          ++ "-dimensional array."-checkBasicOp (Concat i arr1exp arr2exps ressize) = do-  arr1t <- checkArrIdent arr1exp-  arr2ts <- mapM checkArrIdent arr2exps-  let success =-        all-          ( (== dropAt i 1 (arrayDims arr1t))-              . dropAt i 1-              . arrayDims-          )-          arr2ts-  unless success $-    bad $-      TypeError $-        "Types of arguments to concat do not match.  Got "-          ++ pretty arr1t-          ++ " and "-          ++ intercalate ", " (map pretty arr2ts)-  require [Prim int64] ressize-checkBasicOp (Copy e) =-  void $ checkArrIdent e-checkBasicOp (Manifest perm arr) =-  checkBasicOp $ Rearrange perm arr -- Basically same thing!-checkBasicOp (Assert e (ErrorMsg parts) _) = do-  require [Prim Bool] e-  mapM_ checkPart parts-  where-    checkPart ErrorString {} = return ()-    checkPart (ErrorVal t x) = require [Prim t] x-checkBasicOp (UpdateAcc acc is ses) = do-  (shape, ts) <- checkAccIdent acc--  unless (length ses == length ts) $-    bad $-      TypeError $-        "Accumulator requires "-          ++ show (length ts)-          ++ " values, but "-          ++ show (length ses)-          ++ " provided."--  unless (length is == shapeRank shape) $-    bad $-      TypeError $-        "Accumulator requires "-          ++ show (shapeRank shape)-          ++ " indices, but "-          ++ show (length is)-          ++ " provided."--  zipWithM_ require (map pure ts) ses-  consume =<< lookupAliases acc--matchLoopResultExt ::-  Checkable rep =>-  [Param DeclType] ->-  Result ->-  TypeM rep ()-matchLoopResultExt merge loopres = do-  let rettype_ext =-        existentialiseExtTypes (map paramName merge) $-          staticShapes $ map typeOf merge--  bodyt <- mapM subExpResType loopres--  case instantiateShapes (fmap resSubExp . (`maybeNth` loopres)) rettype_ext of-    Nothing ->-      bad $-        ReturnTypeError-          (nameFromString "<loop body>")-          rettype_ext-          (staticShapes bodyt)-    Just rettype' ->-      unless (bodyt `subtypesOf` rettype') $-        bad $-          ReturnTypeError-            (nameFromString "<loop body>")-            (staticShapes rettype')-            (staticShapes bodyt)--checkExp ::-  Checkable rep =>-  Exp (Aliases rep) ->-  TypeM rep ()-checkExp (BasicOp op) = checkBasicOp op-checkExp (If e1 e2 e3 info) = do-  require [Prim Bool] e1-  _ <--    context "in true branch" (checkBody e2)-      `alternative` context "in false branch" (checkBody e3)-  context "in true branch" $ matchBranchType (ifReturns info) e2-  context "in false branch" $ matchBranchType (ifReturns info) e3-checkExp (Apply fname args rettype_annot _) = do-  (rettype_derived, paramtypes) <- lookupFun fname $ map fst args-  argflows <- mapM (checkArg . fst) args-  when (rettype_derived /= rettype_annot) $-    bad . TypeError . pretty $-      "Expected apply result type:"-        </> indent 2 (ppr rettype_derived)-        </> "But annotation is:"-        </> indent 2 (ppr rettype_annot)-  consumeArgs paramtypes argflows-checkExp (DoLoop merge form loopbody) = do-  let (mergepat, mergeexps) = unzip merge-  mergeargs <- mapM checkArg mergeexps--  checkLoopArgs--  binding (scopeOf form) $ do-    form_consumable <- checkForm mergeargs form--    let rettype = map paramDeclType mergepat-        consumable =-          [ (paramName param, mempty)-            | param <- mergepat,-              unique $ paramDeclType param-          ]-            ++ form_consumable--    context "Inside the loop body" $-      checkFun'-        ( nameFromString "<loop body>",-          staticShapes rettype,-          funParamsToNameInfos mergepat-        )-        (Just consumable)-        $ do-          checkFunParams mergepat-          checkBodyDec $ snd $ bodyDec loopbody--          checkStms (bodyStms loopbody) $ do-            context "In loop body result" $-              checkResult $ bodyResult loopbody--            context "When matching result of body with loop parameters" $-              matchLoopResult (map fst merge) $ bodyResult loopbody--            let bound_here =-                  namesFromList $ M.keys $ scopeOf $ bodyStms loopbody-            map (`namesSubtract` bound_here)-              <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody)-  where-    checkLoopVar (p, a) = do-      a_t <- lookupType a-      observe a-      case peelArray 1 a_t of-        Just a_t_r -> do-          checkLParamDec (paramName p) $ paramDec p-          unless (a_t_r `subtypeOf` typeOf (paramDec p)) $-            bad $-              TypeError $-                "Loop parameter " ++ pretty p-                  ++ " not valid for element of "-                  ++ pretty a-                  ++ ", which has row type "-                  ++ pretty a_t_r-          als <- lookupAliases a-          pure (paramName p, als)-        _ ->-          bad $-            TypeError $-              "Cannot loop over " ++ pretty a-                ++ " of type "-                ++ pretty a_t-    checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do-      iparam <- primFParam loopvar $ IntType it-      let mergepat = map fst merge-          funparams = iparam : mergepat-          paramts = map paramDeclType funparams--      consumable <- mapM checkLoopVar loopvars-      boundarg <- checkArg boundexp-      checkFuncall Nothing paramts $ boundarg : mergeargs-      pure consumable-    checkForm mergeargs (WhileLoop cond) = do-      case find ((== cond) . paramName . fst) merge of-        Just (condparam, _) ->-          unless (paramType condparam == Prim Bool) $-            bad $-              TypeError $-                "Conditional '" ++ pretty cond ++ "' of while-loop is not boolean, but "-                  ++ pretty (paramType condparam)-                  ++ "."-        Nothing ->-          bad $-            TypeError $-              "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge variable."-      let mergepat = map fst merge-          funparams = mergepat-          paramts = map paramDeclType funparams-      checkFuncall Nothing paramts mergeargs-      pure mempty--    checkLoopArgs = do-      let (params, args) = unzip merge--      argtypes <- mapM subExpType args--      let expected = expectedTypes (map paramName params) params args-      unless (expected == argtypes) . bad . TypeError . pretty $-        "Loop parameters"-          </> indent 2 (ppTuple' params)-          </> "cannot accept initial values"-          </> indent 2 (ppTuple' args)-          </> "of types"-          </> indent 2 (ppTuple' argtypes)-checkExp (WithAcc inputs lam) = do-  unless (length (lambdaParams lam) == 2 * num_accs) $-    bad . TypeError $-      show (length (lambdaParams lam))-        ++ " parameters, but "-        ++ show num_accs-        ++ " accumulators."--  let cert_params = take num_accs $ lambdaParams lam-  acc_args <- forM (zip inputs cert_params) $ \((shape, arrs, op), p) -> do-    mapM_ (require [Prim int64]) (shapeDims shape)-    elem_ts <- forM arrs $ \arr -> do-      arr_t <- lookupType arr-      unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $-        bad . TypeError $ pretty arr <> " is not an array of outer shape " <> pretty shape-      consume =<< lookupAliases arr-      pure $ stripArray (shapeRank shape) arr_t--    case op of-      Just (op_lam, nes) -> do-        let mkArrArg t = (t, mempty)-        nes_ts <- mapM checkSubExp nes-        unless (nes_ts == lambdaReturnType op_lam) $-          bad $-            TypeError $-              unlines-                [ "Accumulator operator return type: " ++ pretty (lambdaReturnType op_lam),-                  "Type of neutral elements: " ++ pretty nes_ts-                ]-        checkLambda op_lam $-          replicate (shapeRank shape) (Prim int64, mempty)-            ++ map mkArrArg (elem_ts ++ elem_ts)-      Nothing ->-        return ()--    pure (Acc (paramName p) shape elem_ts NoUniqueness, mempty)--  checkAnyLambda False lam $ replicate num_accs (Prim Unit, mempty) ++ acc_args-  where-    num_accs = length inputs-checkExp (Op op) = do-  checker <- asks envCheckOp-  checker op--checkSOACArrayArgs ::-  Checkable rep =>-  SubExp ->-  [VName] ->-  TypeM rep [Arg]-checkSOACArrayArgs width = mapM checkSOACArrayArg-  where-    checkSOACArrayArg v = do-      (t, als) <- checkArg $ Var v-      case t of-        Acc {} -> pure (t, als)-        Array {} -> do-          let argSize = arraySize 0 t-          unless (argSize == width) $-            bad . TypeError $-              "SOAC argument " ++ pretty v ++ " has outer size "-                ++ pretty argSize-                ++ ", but width of SOAC is "-                ++ pretty width-          pure (rowType t, als)-        _ ->-          bad . TypeError $-            "SOAC argument " ++ pretty v ++ " is not an array"--checkType ::-  Checkable rep =>-  TypeBase Shape u ->-  TypeM rep ()-checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d-checkType (Acc cert shape ts _) = do-  requireI [Prim Unit] cert-  mapM_ (require [Prim int64]) $ shapeDims shape-  mapM_ checkType ts-checkType t = mapM_ checkSubExp $ arrayDims t--checkExtType ::-  Checkable rep =>-  TypeBase ExtShape u ->-  TypeM rep ()-checkExtType = mapM_ checkExtDim . shapeDims . arrayShape-  where-    checkExtDim (Free se) = void $ checkSubExp se-    checkExtDim (Ext _) = return ()--checkCmpOp ::-  Checkable rep =>-  CmpOp ->-  SubExp ->-  SubExp ->-  TypeM rep ()-checkCmpOp (CmpEq t) x y = do-  require [Prim t] x-  require [Prim t] y-checkCmpOp (CmpUlt t) x y = checkBinOpArgs (IntType t) x y-checkCmpOp (CmpUle t) x y = checkBinOpArgs (IntType t) x y-checkCmpOp (CmpSlt t) x y = checkBinOpArgs (IntType t) x y-checkCmpOp (CmpSle t) x y = checkBinOpArgs (IntType t) x y-checkCmpOp (FCmpLt t) x y = checkBinOpArgs (FloatType t) x y-checkCmpOp (FCmpLe t) x y = checkBinOpArgs (FloatType t) x y-checkCmpOp CmpLlt x y = checkBinOpArgs Bool x y-checkCmpOp CmpLle x y = checkBinOpArgs Bool x y--checkBinOpArgs ::-  Checkable rep =>-  PrimType ->-  SubExp ->-  SubExp ->-  TypeM rep ()-checkBinOpArgs t e1 e2 = do-  require [Prim t] e1-  require [Prim t] e2--checkPatElem ::-  Checkable rep =>-  PatElemT (LetDec rep) ->-  TypeM rep ()-checkPatElem (PatElem name dec) =-  context ("When checking pattern element " ++ pretty name) $-    checkLetBoundDec name dec--checkFlatDimIndex ::-  Checkable rep =>-  FlatDimIndex SubExp ->-  TypeM rep ()-checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s]--checkFlatSlice ::-  Checkable rep =>-  FlatSlice SubExp ->-  TypeM rep ()-checkFlatSlice (FlatSlice offset idxs) = do-  require [Prim int64] offset-  mapM_ checkFlatDimIndex idxs--checkDimIndex ::-  Checkable rep =>-  DimIndex SubExp ->-  TypeM rep ()-checkDimIndex (DimFix i) = require [Prim int64] i-checkDimIndex (DimSlice i n s) = mapM_ (require [Prim int64]) [i, n, s]--checkStm ::-  Checkable rep =>-  Stm (Aliases rep) ->-  TypeM rep a ->-  TypeM rep a-checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do-  context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs-  context "When checking expression annotation" $ checkExpDec dec-  context ("When matching\n" ++ message "  " pat ++ "\nwith\n" ++ message "  " e) $-    matchPat pat e-  binding (maybeWithoutAliases $ scopeOf stm) $ do-    mapM_ checkPatElem (patElems $ removePatAliases pat)-    m-  where-    -- FIXME: this is wrong.  However, the core language type system-    -- is not strong enough to fully capture the aliases we want (see-    -- issue #803).  Since we eventually inline everything anyway, and-    -- our intra-procedural alias analysis is much simpler and-    -- correct, I could not justify spending time on improving the-    -- inter-procedural alias analysis.  If we ever stop inlining-    -- everything, probably we need to go back and refine this.-    maybeWithoutAliases =-      case stmExp stm of-        Apply {} -> M.map withoutAliases-        _ -> id-    withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec)-    withoutAliases info = info--matchExtPat ::-  Checkable rep =>-  Pat (Aliases rep) ->-  [ExtType] ->-  TypeM rep ()-matchExtPat pat ts =-  unless (expExtTypesFromPat pat == ts) $-    bad $ InvalidPatError pat ts Nothing--matchExtReturnType ::-  Checkable rep =>-  [ExtType] ->-  Result ->-  TypeM rep ()-matchExtReturnType rettype res = do-  ts <- mapM subExpResType res-  matchExtReturns rettype res ts--matchExtBranchType ::-  Checkable rep =>-  [ExtType] ->-  Body (Aliases rep) ->-  TypeM rep ()-matchExtBranchType rettype (Body _ stms res) = do-  ts <- extendedScope (traverse subExpResType res) stmscope-  matchExtReturns rettype res ts-  where-    stmscope = scopeOf stms--matchExtReturns :: [ExtType] -> Result -> [Type] -> TypeM rep ()-matchExtReturns rettype res ts = do-  let problem :: TypeM rep a-      problem =-        bad $-          TypeError $-            unlines-              [ "Type annotation is",-                "  " ++ prettyTuple rettype,-                "But result returns type",-                "  " ++ prettyTuple ts-              ]--  unless (length res == length rettype) problem--  let ctx_vals = zip res ts-      instantiateExt i = case maybeNth i ctx_vals of-        Just (SubExpRes _ se, Prim (IntType Int64)) -> return se-        _ -> problem--  rettype' <- instantiateShapes instantiateExt rettype--  unless (rettype' == ts) problem--validApply ::-  ArrayShape shape =>-  [TypeBase shape Uniqueness] ->-  [TypeBase shape NoUniqueness] ->-  Bool-validApply expected got =-  length got == length expected-    && and-      ( zipWith-          subtypeOf-          (map rankShaped got)-          (map (fromDecl . rankShaped) expected)-      )--type Arg = (Type, Names)--argType :: Arg -> Type-argType (t, _) = t---- | Remove all aliases from the 'Arg'.-argAliases :: Arg -> Names-argAliases (_, als) = als--noArgAliases :: Arg -> Arg-noArgAliases (t, _) = (t, mempty)--checkArg ::-  Checkable rep =>-  SubExp ->-  TypeM rep Arg-checkArg arg = do-  argt <- checkSubExp arg-  als <- subExpAliasesM arg-  return (argt, als)--checkFuncall ::-  Maybe Name ->-  [DeclType] ->-  [Arg] ->-  TypeM rep ()-checkFuncall fname paramts args = do-  let argts = map argType args-  unless (validApply paramts argts) $-    bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args-  consumeArgs paramts args--consumeArgs ::-  [DeclType] ->-  [Arg] ->-  TypeM rep ()-consumeArgs paramts args =-  forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->-    occur [consumption (consumeArg als d)]-  where-    consumeArg als Consume = als-    consumeArg _ _ = mempty---- The boolean indicates whether we only allow consumption of--- parameters.-checkAnyLambda ::-  Checkable rep => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep ()-checkAnyLambda soac (Lambda params body rettype) args = do-  let fname = nameFromString "<anonymous>"-  if length params == length args-    then do-      -- Consumption for this is done explicitly elsewhere.-      checkFuncall-        Nothing-        (map ((`toDecl` Nonunique) . paramType) params)-        $ map noArgAliases args-      let consumable =-            if soac-              then Just $ zip (map paramName params) (map argAliases args)-              else Nothing-      checkFun'-        ( fname,-          staticShapes $ map (`toDecl` Nonunique) rettype,-          [ ( paramName param,-              LParamName $ paramDec param-            )-            | param <- params-          ]-        )-        consumable-        $ do-          checkLambdaParams params-          mapM_ checkType rettype-          checkLambdaBody rettype body-    else-      bad $-        TypeError $-          "Anonymous function defined with " ++ show (length params) ++ " parameters:\n"-            ++ pretty params-            ++ "\nbut expected to take "-            ++ show (length args)-            ++ " arguments."--checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep ()-checkLambda = checkAnyLambda True--checkPrimExp :: Checkable rep => PrimExp VName -> TypeM rep ()-checkPrimExp ValueExp {} = return ()-checkPrimExp (LeafExp v pt) = requireI [Prim pt] v-checkPrimExp (BinOpExp op x y) = do-  requirePrimExp (binOpType op) x-  requirePrimExp (binOpType op) y-checkPrimExp (CmpOpExp op x y) = do-  requirePrimExp (cmpOpType op) x-  requirePrimExp (cmpOpType op) y-checkPrimExp (UnOpExp op x) = requirePrimExp (unOpType op) x-checkPrimExp (ConvOpExp op x) = requirePrimExp (fst $ convOpType op) x-checkPrimExp (FunExp h args t) = do-  (h_ts, h_ret, _) <--    maybe-      (bad $ TypeError $ "Unknown function: " ++ h)-      return-      $ M.lookup h primFuns-  when (length h_ts /= length args) $-    bad $-      TypeError $-        "Function expects " ++ show (length h_ts)-          ++ " parameters, but given "-          ++ show (length args)-          ++ " arguments."-  when (h_ret /= t) $-    bad $-      TypeError $-        "Function return annotation is " ++ pretty t-          ++ ", but expected "-          ++ pretty h_ret-  zipWithM_ requirePrimExp h_ts args--requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep ()-requirePrimExp t e = context ("in PrimExp " ++ pretty e) $ do-  checkPrimExp e-  unless (primExpType e == t) $-    bad $-      TypeError $-        pretty e ++ " must have type " ++ pretty t--class ASTRep rep => CheckableOp rep where-  checkOp :: OpWithAliases (Op rep) -> TypeM rep ()-  -- ^ Used at top level; can be locally changed with 'checkOpWith'.---- | The class of representations that can be type-checked.-class (ASTRep rep, CanBeAliased (Op rep), CheckableOp rep) => Checkable rep where-  checkExpDec :: ExpDec rep -> TypeM rep ()-  checkBodyDec :: BodyDec rep -> TypeM rep ()-  checkFParamDec :: VName -> FParamInfo rep -> TypeM rep ()-  checkLParamDec :: VName -> LParamInfo rep -> TypeM rep ()-  checkLetBoundDec :: VName -> LetDec rep -> TypeM rep ()-  checkRetType :: [RetType rep] -> TypeM rep ()-  matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()-  primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep))-  matchReturnType :: [RetType rep] -> Result -> TypeM rep ()-  matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()-  matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep ()--  default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep ()-  checkExpDec = return--  default checkBodyDec :: BodyDec rep ~ () => BodyDec rep -> TypeM rep ()-  checkBodyDec = return--  default checkFParamDec :: FParamInfo rep ~ DeclType => VName -> FParamInfo rep -> TypeM rep ()-  checkFParamDec _ = checkType--  default checkLParamDec :: LParamInfo rep ~ Type => VName -> LParamInfo rep -> TypeM rep ()-  checkLParamDec _ = checkType--  default checkLetBoundDec :: LetDec rep ~ Type => VName -> LetDec rep -> TypeM rep ()-  checkLetBoundDec _ = checkType--  default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep ()-  checkRetType = mapM_ $ checkExtType . declExtTypeOf--  default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()-  matchPat pat = matchExtPat pat <=< expExtType--  default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))-  primFParam name t = return $ Param mempty name (Prim t)--  default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep ()-  matchReturnType = matchExtReturnType . map fromDecl--  default matchBranchType :: BranchType rep ~ ExtType => [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()-  matchBranchType = matchExtBranchType--  default matchLoopResult ::-    FParamInfo rep ~ DeclType =>-    [FParam (Aliases rep)] ->-    Result ->-    TypeM rep ()-  matchLoopResult = matchLoopResultExt

@@ -53,6 +53,7 @@     zEncodeString,     atMostChars,     invertMap,+    fixPoint,   ) where @@ -462,3 +463,8 @@   M.toList m     & fmap (swap . first S.singleton)     & foldr (uncurry $ M.insertWith (<>)) mempty++fixPoint :: Eq a => (a -> a) -> a -> a+fixPoint f x =+  let x' = f x+   in if x' == x then x else fixPoint f x'

@@ -26,6 +26,7 @@  import Control.Monad.Except import Control.Monad.Free.Church+import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe@@ -620,25 +621,41 @@   toArray' (indexShape is rowshape) <$> mapM (indexArray is . (arr !)) js indexArray _ v = Just v -updateArray :: [Indexing] -> Value -> Value -> Maybe Value-updateArray (IndexingFix i : is) (ValueArray shape arr) v+writeArray :: [Indexing] -> Value -> Value -> Maybe Value+writeArray slice x y = runIdentity $ updateArray (\_ y' -> pure y') slice x y++updateArray ::+  Monad m =>+  (Value -> Value -> m Value) ->+  [Indexing] ->+  Value ->+  Value ->+  m (Maybe Value)+updateArray f (IndexingFix i : is) (ValueArray shape arr) v   | i >= 0,     i < n = do-    v' <- updateArray is (arr ! i') v-    Just $ ValueArray shape $ arr // [(i', v')]+    v' <- updateArray f is (arr ! i') v+    pure $ do+      v'' <- v'+      Just $ ValueArray shape $ arr // [(i', v'')]   | otherwise =-    Nothing+    pure Nothing   where     n = arrayLength arr     i' = fromIntegral i-updateArray (IndexingSlice start end stride : is) (ValueArray shape arr) (ValueArray _ v) = do-  arr_is <- indexesFor start end stride $ arrayLength arr-  guard $ length arr_is == arrayLength v-  let update arr' (i, v') = do-        x <- updateArray is (arr ! i) v'-        return $ arr' // [(i, x)]-  fmap (ValueArray shape) $ foldM update arr $ zip arr_is $ elems v-updateArray _ _ v = Just v+updateArray f (IndexingSlice start end stride : is) (ValueArray shape arr) (ValueArray _ v)+  | Just arr_is <- indexesFor start end stride $ arrayLength arr,+    length arr_is == arrayLength v = do+    let update (Just arr') (i, v') = do+          x <- updateArray f is (arr ! i) v'+          pure $ do+            x' <- x+            Just $ arr' // [(i, x')]+        update Nothing _ = pure Nothing+    fmap (fmap (ValueArray shape)) $ foldM update (Just arr) $ zip arr_is $ elems v+  | otherwise =+    pure Nothing+updateArray f _ x y = Just <$> f x y  evalDimIndex :: Env -> DimIndex -> EvalM Indexing evalDimIndex env (DimFix x) =@@ -903,7 +920,7 @@   let Ident src_vn (Info src_t) _ = src   dest' <-     maybe oob return-      =<< updateArray <$> mapM (evalDimIndex env) is+      =<< writeArray <$> mapM (evalDimIndex env) is       <*> evalTermVar env (qualName src_vn) (toStruct src_t)       <*> eval env v   let t = T.BoundV [] $ toStruct $ unInfo $ identType dest@@ -1044,7 +1061,7 @@     _ -> error $ "Cannot logically negate " ++ pretty ev eval env (Update src is v loc) =   maybe oob return-    =<< updateArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v+    =<< writeArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v   where     oob = bad loc env "Bad update" eval env (RecordUpdate src all_fs v _ _) =@@ -1611,7 +1628,7 @@       where         update :: Value -> (Maybe [Value], Value) -> Value         update arr (Just idxs@[_, _], v) =-          fromMaybe arr $ updateArray (map (IndexingFix . asInt64) idxs) arr v+          fromMaybe arr $ writeArray (map (IndexingFix . asInt64) idxs) arr v         update _ _ =           error "scatter_2d expects 2-dimensional indices"     def "scatter_3d" = Just $@@ -1626,27 +1643,42 @@       where         update :: Value -> (Maybe [Value], Value) -> Value         update arr (Just idxs@[_, _, _], v) =-          fromMaybe arr $ updateArray (map (IndexingFix . asInt64) idxs) arr v+          fromMaybe arr $ writeArray (map (IndexingFix . asInt64) idxs) arr v         update _ _ =           error "scatter_3d expects 3-dimensional indices"-    def "hist" = Just $-      fun6t $ \_ arr fun _ is vs ->-        case arr of-          ValueArray shape arr' ->-            ValueArray shape-              <$> foldM-                (update fun)-                arr'-                (zip (map asInt $ snd $ fromArray is) (snd $ fromArray vs))-          _ ->-            error $ "hist expects array, but got: " ++ pretty arr+    def "hist_1d" = Just . fun6t $ \_ arr fun _ is vs ->+      foldM+        (update fun)+        arr+        (zip (map asInt64 $ snd $ fromArray is) (snd $ fromArray vs))       where-        update fun arr' (i, v) =-          if i >= 0 && i < arrayLength arr'-            then do-              v' <- apply2 noLoc mempty fun (arr' ! i) v-              return $ arr' // [(i, v')]-            else return arr'+        op = apply2 mempty mempty+        update fun arr (i, v) =+          fromMaybe arr <$> updateArray (op fun) [IndexingFix i] arr v+    def "hist_2d" = Just . fun6t $ \_ arr fun _ is vs ->+      foldM+        (update fun)+        arr+        (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))+      where+        op = apply2 mempty mempty+        update fun arr (Just idxs@[_, _], v) =+          fromMaybe arr+            <$> updateArray (op fun) (map (IndexingFix . asInt64) idxs) arr v+        update _ _ _ =+          error "hist_2d: bad index value"+    def "hist_3d" = Just . fun6t $ \_ arr fun _ is vs ->+      foldM+        (update fun)+        arr+        (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))+      where+        op = apply2 mempty mempty+        update fun arr (Just idxs@[_, _, _], v) =+          fromMaybe arr+            <$> updateArray (op fun) (map (IndexingFix . asInt64) idxs) arr v+        update _ _ _ =+          error "hist_2d: bad index value"     def "partition" = Just $       fun3t $ \k f xs -> do         let (ShapeDim _ rowshape, xs') = fromArray xs@@ -1739,7 +1771,7 @@         ShapeDim n1 (ShapeDim n2 _) -> do           let iota x = [0 .. x -1]               f arr' (i, j) =-                updateArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'+                writeArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j] v           case foldM f arr [(i, j) | i <- iota n1, j <- iota n2] of             Just arr' -> pure arr'@@ -1779,7 +1811,7 @@         ShapeDim n1 (ShapeDim n2 (ShapeDim n3 _)) -> do           let iota x = [0 .. x -1]               f arr' (i, j, l) =-                updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'+                writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l] v           case foldM f arr [(i, j, l) | i <- iota n1, j <- iota n2, l <- iota n3] of             Just arr' -> pure arr'@@ -1823,7 +1855,7 @@         ShapeDim n1 (ShapeDim n2 (ShapeDim n3 (ShapeDim n4 _))) -> do           let iota x = [0 .. x -1]               f arr' (i, j, l, m) =-                updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'+                writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l, IndexingFix m] v           case foldM f arr [(i, j, l, m) | i <- iota n1, j <- iota n2, l <- iota n3, m <- iota n4] of             Just arr' -> pure arr'

@@ -909,18 +909,42 @@                    $ RetType [] . Scalar . Record . M.fromList $                      zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]]                ),-               ( "hist",+               ( "hist_1d",                  IntrinsicPolyFun                    [tp_a, sp_n, sp_m]                    [ Scalar $ Prim $ Signed Int64,-                     uarr_a $ shape [n],+                     uarr_a $ shape [m],                      Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),                      Scalar t_a,-                     Array () Nonunique (Prim $ Signed Int64) (shape [m]),-                     arr_a (shape [m])+                     Array () Nonunique (tupInt64 1) (shape [n]),+                     arr_a (shape [n])                    ]-                   $ RetType [] $ uarr_a $ shape [n]+                   $ RetType [] $ uarr_a $ shape [m]                ),+               ( "hist_2d",+                 IntrinsicPolyFun+                   [tp_a, sp_n, sp_m, sp_k]+                   [ Scalar $ Prim $ Signed Int64,+                     uarr_a $ shape [m, k],+                     Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),+                     Scalar t_a,+                     Array () Nonunique (tupInt64 2) (shape [n]),+                     arr_a (shape [n])+                   ]+                   $ RetType [] $ uarr_a $ shape [m, k]+               ),+               ( "hist_3d",+                 IntrinsicPolyFun+                   [tp_a, sp_n, sp_m, sp_k, sp_l]+                   [ Scalar $ Prim $ Signed Int64,+                     uarr_a $ shape [m, k, l],+                     Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),+                     Scalar t_a,+                     Array () Nonunique (tupInt64 3) (shape [n]),+                     arr_a (shape [n])+                   ]+                   $ RetType [] $ uarr_a $ shape [m, k, l]+               ),                ( "map",                  IntrinsicPolyFun                    [tp_a, tp_b, sp_n]@@ -1226,9 +1250,10 @@     intrinsicBinOp Geq = ordering     intrinsicBinOp _ = Nothing +    tupInt64 1 =+      Prim $ Signed Int64     tupInt64 x =-      Record . M.fromList . zip tupleFieldNames $-        replicate x $ Scalar $ Prim $ Signed Int64+      tupleRecord $ replicate x $ Scalar $ Prim $ Signed Int64  -- | The largest tag used by an intrinsic - this can be used to -- determine whether a 'VName' refers to an intrinsic or a user-defined name.

@@ -1303,10 +1303,12 @@         typeError usage mempty . withIndexLink "ambiguous-type" $           "Type is ambiguous (could be one of" <+> commasep (map ppr ots) <> ")."             </> "Add a type annotation to disambiguate the type."-    fixOverloaded (_, NoConstraint _ usage) =-      typeError usage mempty . withIndexLink "ambiguous-type" $-        "Type of expression is ambiguous."-          </> "Add a type annotation to disambiguate the type."+    fixOverloaded (v, NoConstraint _ usage) = do+      -- See #1552.+      unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $+        Scalar $ tupleRecord []+      when (v `S.member` tyvars_at_toplevel) $+        warn usage "Defaulting ambiguous type to ()."     fixOverloaded (_, Equality usage) =       typeError usage mempty . withIndexLink "ambiguous-type" $         "Type is ambiguous (must be equality type)."