packages feed

futhark 0.14.1 → 0.15.1

raw patch · 152 files changed

+13086/−6615 lines, 152 filesdep ~neat-interpolation

Dependency ranges changed: neat-interpolation

Files

+ docs/binary-data-format.rst view
@@ -0,0 +1,79 @@+.. _binary-data-format:++Binary Data Format+==================++Futhark programs compiled to an executable support both textual and binary+input. Both are read via standard input, and can be mixed, such that one+argument to an entry point may be binary, and another may be textual. The binary+input format takes up significantly less space on disk, and can be read much+faster than the textual format. This chapter describes the binary input format+and its current limitations. The input formats (whether textual or binary) are+not used for Futhark programs compiled to libraries, which instead use whichever+format is supported by their host language.++Currently reading binary input is only supported for programs+generated by ``futhark c``/``futhark opencl``, and+``futhark py``/``futhark pyopencl``.  It is *not* supported for+``futhark run``.++You can generate random data in the binary format with ``futhark+dataset`` (:ref:`futhark-dataset(1)`).  This tool can also be used to+convert between binary and textual data.++Futhark-generated executables can be asked to generate binary output+with the ``-b`` option.++Specification+-------------++Elements that are bigger than one byte are always stored using little endian --+we mostly run our code on x86 hardware so this seemed like a reasonable choice.++When reading input for an argument to the entry function, we need to be able to+differentiate between text and binary input. If the first non-whitespace+character of the input is a ``b`` we will parse this argument as binary,+otherwise we will parse it in text format. Allowing preceding whitespace+characters makes it easy to use binary input for some arguments, and text input+for others.++The general format has this header::++  b <version> <num_dims> <type>++Where ``version`` is a byte containing the version of the binary format used for+encoding (currently 2), ``num_dims`` is the number of dimensions in the array as+a single byte (0 for scalar), and ``type`` is a 4 character string describing+the type of the values(s) -- see below for more details.++Encoding a scalar value is done by treating it as a 0-dimensional array::++  b <version> 0 <type> <value>++To encode an array we must encode the number of dimensions ``n`` as a single+byte, each dimension ``dim_i`` as an unsigned 64-bit little endian integer, and+finally all the values in their binary little endian representation::++  b <version> <n> <type> <dim_1> <dim_2> ... <dim_n> <values>+++Type Values+~~~~~~~~~~~++A type is identified by a 4 character ASCII string (four bytes). Valid+types are::++  "  i8"+  " i16"+  " i32"+  " i64"+  "  u8"+  " u16"+  " u32"+  " u64"+  " f32"+  " f64"+  "bool"++Note that unsigned and signed integers have the same byte-level+representation.
+ docs/c-porting-guide.rst view
@@ -0,0 +1,178 @@+.. _c-porting-guide:++C Porting Guide+===============++This short document contains a collection of tips and tricks for+porting simple numerical C code to Futhark.  Futhark's sequential+fragment is powerful enough to permit a rather straightforward+translation of sequential C code that does not rely on pointer+mutation.  Additionally, we provide hints on how to recognise C coding+patterns that are symptoms of C's weak type system, and how better to+organise it in Futhark.++One intended audience of this document is a programmer who needs to+translate a benchmark application written in C, or needs to use a+simple numerical algorithm that is already available in the form of C+source code.++Where This Guide Falls Short+----------------------------++Some C code makes use of unstructured returns and nonlocal exits+(``return`` inside loops, for example).  These are not easy to express+in Futhark, and will require massaging the control flow a bit.  C code+that uses ``goto`` is likewise not easy to port.++Types+-----++Futhark provides scalar types that match the ones commonly used in C:+``u8``/``u16``/``u32``/``u64`` for the unsigned integers,+``i8``/``i16``/``i32``/``i64`` for the signed, and ``f32``/``f64`` for+``float`` and ``double`` respectively.  In contrast to C, Futhark does+not automatically promote types in expressions - you will have to+manually make sure that both operands to e.g. a multiplication are of+the exact same type.  This means that you will need to understand+exactly which types a given expression in original C program operates+on, which generally boils down to converting the type of the+(type-wise) smaller operand to that of the larger.  Note that the+Futhark ``bool`` type is not considered a number.++Operators+---------++Most of the C operators can be found in Futhark with their usual+names.  Note however that the Futhark ``/`` and ``%`` operators for+integers round towards negative infinity, whereas their counterparts+in C round towards zero.  You can write ``//`` and ``%%`` if you want+the C behaviour.  There is no difference if both operands are+non-zero, but ``//`` and ``%%`` may be slightly faster.  For unsigned+numbers, they are exactly the same.++Variable Mutation+-----------------++As a sequential language, most C programs quite obviously rely heavily+on mutating variables.  However, in many programs, this is done in a+static manner without indirection through pointers (except for arrays;+see below), which is conceptually similar to just declaring a new+variable of the same name that shadows the old one.  If this is the+case, a C assignment can generally be translated to just a+``let``-binding.  As an example, let us consider the following+function for computing the modular multiplicative inverse of a 16-bit+unsigned integer (part of the IDEA encryption algorithm):++.. code-block:: c++  static uint16_t ideaInv(uint16_t a) {+    uint32_t b;+    uint32_t q;+    uint32_t r;+    int32_t t;+    int32_t u;+    int32_t v;++    b = 0x10001;+    u = 0;+    v = 1;++    while(a > 0)+      {+        q = b / a;+        r = b % a;++        b = a;+        a = r;++        t = v;+        v = u - q * v;+        u = t;+      }++    if(u < 0)+      u += 0x10001;++    return u;+  }++Each iteration of the loop mutates the variables ``a``, ``b``, ``v``,+and ``u`` in ways that are visible to the following iteration.+Conversely, the "mutations" of ``q``, ``r``, and ``t`` are not truly+mutations, and the variable declarations could be moved inside the+loop if we wished.  Presumably, the C programmer left them outside for+aesthetic reasons.  When translating such code, it is important to+determine exactly how much *true* mutation is going on, and how much+is just reuse of variable space.  This can usually be done by checking+whether a variable is read before it is written in any given+iteration - if not, then it is not true mutation.  The variables that+change value from one iteration of the loop to the next will need to+be maintained as *merge parameters* of the Futhark ``do``-loop.++The Futhark program resulting from a straightforward port looks as+follows:++.. code-block:: futhark++  let main(a: u16): u32 =+    let b = 0x10001u32+    let u = 0i32+    let v = 1i32 in+    let (_,_,u,_) = loop ((a,b,u,v)) while a > 0u16 do+      let q = b / u32.u16(a)+      let r = b % u32.u16(a)++      let b = u32.u16(a)+      let a = u16.u32(r)++      let t = v+      let v = u - i32.u32 (q) * v+      let u = t in+      (a,b,u,v)++    in u32.i32(if u < 0 then u + 0x10001 else u)++Note the heavy use of type conversion and type suffixes for constants.+This is necessary due to Futhark's lack of implicit conversions.  Note+also the conspicuous way in which the ``do``-loop is written - the+result of a loop iteration consists of variables whose names are+identical to those of the merge parameters.++This program can still be massaged to make it more idiomatic Futhark -+for example, the variable ``t`` only serves to store the old value of+``v`` that is otherwise clobbered.  This can be written more elegantly+by simply inlining the expressions in the result part of the loop+body.++Arrays+------++Dynamically sized multidimensional arrays are somewhat awkward in C,+and are often simulated via single-dimensional arrays with explicitly+calculated indices:++.. code:: c++  a[i * M + j] = foo;++This indicates a two-dimensional array ``a`` whose *inner* dimension+is of size ``M``.  We can usually look at where ``a`` is allocated to+figure out what the size of the outer dimension must be:++.. code:: c++  a = malloc(N * M * sizeof(int));++We see clearly that ``a`` is a two-dimensional integer array of size+``N`` times ``M`` - or of type ``[N][M]i32`` in Futhark.  Thus, the update+expression above would be translated as::++  let a[i,j] = foo in+  ...++C programs usually first allocate an array, then enter a loop to+provide its initial values.  This is not possible in Futhark -+consider whether you can write it as a ``replicate``, an ``iota``, or+a ``map``.  In the worst case, use ``replicate`` to obtain an array of+the desired size, then use a ``do``-loop with in-place updates to+initialise it (but note that this will run stricly sequentially).
docs/conf.py view
@@ -60,13 +60,12 @@ # # The short X.Y version. -# No reason for a full YAML parser; let's just hack it.+# No reason for a cabal file parser; let's just hack it. def get_version():-    # Get lines-    lines = open('../package.yaml', 'r').read().split('\n')-    # Find version line.-    version_line = lines[1]-    return re.search('version: "(.*)"', version_line).group(1)+    # Get cabal file+    cabal_file = open('../futhark.cabal', 'r').read()+    # Extract version+    return re.search('version:[ ]*([^ ]*)', cabal_file).group(1)  version = get_version() # The full version, including alpha/beta/rc tags.@@ -109,7 +108,7 @@      tokens = {         'root': [-            (r'if|then|else|let|loop|in|val|for|do|with|local|open|include|import|type|entry|module|while|unsafe|module', token.Keyword),+            (r'(if|then|else|let|loop|in|val|for|do|with|local|open|include|import|type|entry|module|while|unsafe|module)\b', token.Keyword),             (r"[a-zA-Z_][a-zA-Z0-9_']*", token.Name),             (r"-- .*", token.Comment),             (r'.', token.Text)
+ docs/hacking.rst view
@@ -0,0 +1,91 @@+.. _hacking:++Hacking on the Futhark Compiler+===============================++The Futhark compiler is a significant body of code with a not entirely+straightforward design.  The main reference is the `documentation of+the compiler internals`_ that is automatically generated by Haddock.+If you feel that it is incomplete, or lacks an explanation, then feel+free to report it as an issue on the `GitHub page`_.  Documentation+bugs are bugs too.++.. _`documentation of the compiler internals`: https://futhark-lang.org/haddock/+.. _`GitHub page`: https://github.com/diku-dk/futhark++The Futhark compiler is built using `Stack`_.  It's a good idea to+familiarise yourself with how it works.  As a starting point, here are+a few hints:++  * When testing, pass ``--fast`` to ``stack`` to disable the GHC+    optimiser.  This speeds up builds considerably (although it still+    takes a while).  The resulting Futhark compiler will run slower,+    but it is not something you will notice for small test programs.++  * When debugging, pass ``--profile`` to ``stack``.  This will build+    the Futhark compiler with debugging information (not just+    profiling).  In particular, hard crashes will print a stack trace.+    You can also get actual profiling information by passing+    ``+RTS -pprof-all -RTS`` to the Futhark compiler.  This asks the+    Haskell runtime to print profiling information to a file.  For+    more information, see the `Profiling`_ chapter in the GHC User+    Guide.++  * You may wish to set the environment variable+    ``FUTHARK_COMPILER_DEBUGGING=1``.  Currently this only has the+    effect of making the frontend print internal names, but it may+    control more things in the future.++.. _`stack`: https://docs.haskellstack.org/en/stable/README/+.. _`Profiling`: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html++Debugging Internal Type Errors+------------------------------++The Futhark compiler uses a typed core language, and the type checker+is run after every pass.  If a given pass produces a program with+inconsistent typing, the compiler will report an error and abort.+While not every compiler bug will manifest itself as a core language+type error (unfortunately), many will.  To write the erroneous core+program to a file in case of type error, pass ``-v filename`` to the+compiler.  This will also enable verbose output, so you can tell which+pass fails.  The ``-v`` option is also useful when the compiler itself+crashes, as you can at least tell where in the pipeline it got to.++Checking Generated Code+-----------------------++Hacking on the compiler will often involve inspecting the quality of+the generated code.  The recommended way to do this is to use+:ref:`futhark-c(1)` or :ref:`futhark-opencl(1)` to compile a Futhark+program to an executable.  These backends insert various forms of+instrumentation that can be enabled by passing run-time options to the+generated executable.++  * As a first resort, use ``-t`` option to use the built-in runtime+    measurements.  A nice trick is to pass ``-t /dev/stderr``, while+    redirecting standard output to ``/dev/null``.  This will print the+    runtime on the screen, but not the execution result.++  * Optionally use ``-r`` to ask for several runs, e.g. ``-r 10``.  If+    combined with ``-t``, this will cause several runtimes to be+    printed (one per line).  The :ref:`futhark-bench(1)` tool itself+    uses ``-t`` and ``-r`` to perform its measurements.++  * Pass ``-D`` to have the program print information on allocation+    and deallocation of memory.++  * (:ref:`futhark-opencl(1)` only) Use the ``-D`` option to enable+    synchronous execution.  ``clFinish()`` will be called after most+    OpenCL operations, and a running log of kernel invocations will be+    printed.  At the end of execution, the program prints a table+    summarising all kernels and their total runtime and average+    runtime.++Using ``futhark dev``+---------------------++For debugging specific compiler passes, the ``futhark dev`` subcommand+allows you to tailor your own compilation pipeline using command line+options.  It is also useful for seeing what the AST looks like after+specific passes.
+ docs/installation.rst view
@@ -0,0 +1,337 @@+.. _installation:++Installation+============++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:`macos-installation`.++Futhark is also available via `Nix <https://nixos.org/nix/>`_.  If you+are using Nix, simply install the ``futhark`` derivation from Nixpkgs.++Dependencies+------------++On non-Windows, you will need to have the ``gmp`` and ``tinfo``+libraries installed.  These are pretty common, so you may already have+them.  On Debian-like systems (e.g. Ubuntu), use::++  sudo apt install libtinfo-dev libgmp-dev++If you install Futhark via a package manager (e.g. Homebrew, Nix, or+AUR), you shouldn't need to worry about this.++Compiling from source+---------------------++We use the the `Haskell Tool Stack`_ to handle dependencies and+compilation of the Futhark compiler, so you will need to install the+``stack`` tool.  Fortunately, the ``stack`` developers provide ample+documentation about `installing Stack`_ on a multitude of operating+systems.  If you're lucky, it may even be in your local package+repository.++You can either retrieve a `source release tarball+<https://github.com/diku-dk/futhark/releases>`_ or perform a checkout+of our Git repository::++  $ git clone https://github.com/diku-dk/futhark.git++This will create a directory ``futhark``, which you must enter::++  $ cd futhark++To get all the prerequisites for building the Futhark compiler+(including, if necessary, the appropriate version of the Haskell+compiler), run::++  $ stack setup++Note that this will not install anything system-wide and will have no+effect outside the Futhark build directory. Now you can run the+following command to build the Futhark compiler, including all+dependencies::++  $ stack build++The Futhark compiler and its tools will now be built.  This step+typically requires at least 8GiB of memory.  You may be able to build+it on a smaller machine by adding the ``--fast`` option, although the+resulting Futhark compiler binary will run slower.++After building, you can copy the binaries to your ``$HOME/.local/bin``+directory by running::++  $ stack install++Note that this does not install the Futhark manual pages.++Installing from a precompiled snapshot+--------------------------------------++Tarballs of binary releases can be `found online+<https://futhark-lang.org/releases/>`_, but are available only for+very few platforms (as of this writing, only GNU/Linux on x86_64).+See the enclosed ``README.md`` for installation instructions.++Furthermore, every day a program automatically clones the Git+repository, builds the compiler, and packages a simple tarball+containing the resulting binaries, built manpages, and a simple+``Makefile`` for installing.  The implication is that these tarballs+are not vetted in any way, nor more stable than Git HEAD at any+particular moment in time.  They are provided for users who wish to+use the most recent code, but are unable to compile Futhark+themselves.++At the moment, we build such snapshots only for a single operating+system:++Linux (x86_64)+  `futhark-nightly-linux-x86_64.tar.xz <https://futhark-lang.org/releases/futhark-nightly-linux-x86_64.tar.xz>`_++In time, we hope to make snapshots available for more platforms, but+we are limited by system availability.++.. _`Haskell tool stack`: http://docs.haskellstack.org/+.. _`installing Stack`: http://docs.haskellstack.org/#how-to-install++.. _linux-installation:++Installing Futhark on Linux+---------------------------++* `Linuxbrew`_ is a distribution-agnostic package manager that+  contains a formula for Futhark.  If Linuxbrew is installed (which+  does not require ``root`` access), installation is as easy as::++    $ brew install futhark++  Note that as of this writing, Linuxbrew is hampered by limited+  compute resources for building packages, so the Futhark version may+  be a bit behind.++* Arch Linux users can use a `futhark-nightly package+  <https://aur.archlinux.org/packages/futhark-nightly/>`_.++Otherwise (or if the version in the package system is too old), your+best bet is to install from source or use a tarball, as described+above.++.. _`Linuxbrew`: http://linuxbrew.sh/++.. _macos-installation:++Using OpenCL or CUDA+~~~~~~~~~~~~~~~~~~~~++If you wish to use ``futhark opencl`` or ``futhark cuda``, you must+have the OpenCL or CUDA libraries installed, respectively.  Consult+your favourite search engine for instructions on how to do this on+your distribution.  It is usually not terribly difficult if you+already have working GPU drivers.++For OpenCL, note that there is a distinction between the general+OpenCL host library (``OpenCL.so``) that Futhark links against, and+the *Installable Client Driver* (ICD) that OpenCL uses to actually+talk to the hardware.  You will need both.  Working display drivers+for the GPU does not imply that an ICD has been installed - they are+usually in a separate package.  Consult your favourite search engine+for details.++Installing Futhark on macOS+---------------------------++Futhark is available on `Homebrew`_, and the latest release can be+installed via::++  $ brew install futhark++Or you can install the unreleased development version with::++  $ brew install --HEAD futhark++This has to compile from source, so it takes a little while (20-30+minutes is common).++macOS ships with one OpenCL platform and various devices.  One of+these devices is always the CPU, which is not fully functional, and is+never picked by Futhark by default.  You can still select it manually+with the usual mechanisms (see :ref:`executable-options`), but it is+unlikely to be able to run most Futhark programs.  Depending on the+system, there may also be one or more GPU devices, and Futhark will+simply pick the first one as always.  On multi-GPU MacBooks, this is+is the low-power integrated GPU.  It should work just fine, but you+might have better performance if you use the dedicated GPU instead.+On a Mac with an AMD GPU, this is done by passing ``-dAMD`` to the+generated Futhark executable.++.. _`Homebrew`: https://brew.sh/++.. _windows-installation:++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.++.. _`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
+ docs/language-reference.rst view
@@ -0,0 +1,1567 @@+.. _language-reference:++Language Reference+==================++This reference seeks to describe every construct in the Futhark+language.  It is not presented in a tutorial fashion, but rather+intended for quick lookup and documentation of subtleties.  For this+reason, it is not written in a bottom-up manner, and some concepts may+be used before they are fully defined.  It is a good idea to have a+basic grasp of Futhark (or some other functional programming language)+before reading this reference.  An ambiguous grammar is given for the+full language.  The text describes how ambiguities are resolved in+practice (for example by applying rules of operator precedence).++This reference describes only the language itself.  Documentation for+the basis library is `available elsewhere+<https://futhark-lang.org/docs/>`_.++Identifiers and Keywords+------------------------++.. productionlist::+   id: `letter` (`letter` | "_" | "'")* | "_" `id`+   quals: (`id` ".")++   qualid: `id` | `quals` `id`+   binop: `opstartchar` `opchar`*+   qualbinop: `binop` | `quals` `binop` | "`" `qualid` "`"+   fieldid: `decimal` | `id`+   opstartchar: "+" | "-" | "*" | "/" | "%" | "=" | "!" | ">" | "<" | "|" | "&" | "^"+   opchar: `opstartchar` | "."+   constructor: "#" `id`++Many things in Futhark are named. When we are defining something, we+give it an unqualified name (`id`).  When referencing something inside+a module, we use a qualified name (`qualid`).  The constructor names+of a sum type (:ref:`compounds`) are identifiers prefixed with ``#``,+with no space afterwards.  The fields of a record are named with+`fieldid`.  Note that a `fieldid` can be a decimal number.  Futhark+has three distinct name spaces: terms, module types, and types.+Modules (including parametric modules) and values both share the term+namespace.++.. _primitives:++Primitive Types and Values+--------------------------++.. productionlist::+   literal: `intnumber` | `floatnumber` | "true" | "false"++Boolean literals are written ``true`` and ``false``.  The primitive+types in Futhark are the signed integer types ``i8``, ``i16``,+``i32``, ``i64``, the unsigned integer types ``u8``, ``u16``, ``u32``,+``u64``, the floating-point types ``f32``, ``f64``, as well as+``bool``.  An ``f32`` is always a single-precision float and a ``f64``+is a double-precision float.++.. productionlist::+   int_type: "i8" | "i16" | "i32" | "i64" | "u8" | "u16" | "u32" | "u64"+   float_type: "f32" | "f64"++Numeric literals can be suffixed with their intended type.  For+example ``42i8`` is of type ``i8``, and ``1337e2f64`` is of type+``f64``.  If no suffix is given, the type of the literal will be+inferred based on its use.  If the use is not constrained, integral+literals will be assigned type ``i32``, and decimal literals type+``f64``.  Hexadecimal literals are supported by prefixing with ``0x``,+and binary literals by prefixing with ``0b``.++Floats can also be written in hexadecimal format such as ``0x1.fp3``,+instead of the usual decimal notation. Here, ``0x1.f`` evaluates to+``1 15/16`` and the ``p3`` multiplies it by ``2^3 = 8``.++.. productionlist::+   intnumber: (`decimal` | `hexadecimal` | `binary`) [`int_type`]+   decimal: `decdigit` (`decdigit` |"_")*+   hexadecimal: 0 ("x" | "X") `hexdigit` (`hexdigit` |"_")*+   binary: 0 ("b" | "B") `bindigit` (`bindigit` | "_")*++.. productionlist::+   floatnumber: (`pointfloat` | `exponentfloat`) [`float_type`]+   pointfloat: [`intpart`] `fraction`+   exponentfloat: (`intpart` | `pointfloat`) `exponent`+   hexadecimalfloat: 0 ("x" | "X") `hexintpart` `hexfraction` ("p"|"P") ["+" | "-"] `decdigit`++   intpart: `decdigit` (`decdigit` |"_")*+   fraction: "." `decdigit` (`decdigit` |"_")*+   hexintpart: `hexdigit` (`hexdigit` | "_")*+   hexfraction: "." `hexdigit` (`hexdigit` |"_")*+   exponent: ("e" | "E") ["+" | "-"] `decdigit`+++.. productionlist::+   decdigit: "0"..."9"+   hexdigit: `decdigit` | "a"..."f" | "A"..."F"+   bindigit: "0" | "1"++.. _compounds:++Compound Types and Values+~~~~~~~~~~~~~~~~~~~~~~~~~++.. productionlist::+   type:   `qualid`+       : | `array_type`+       : | `tuple_type`+       : | `record_type`+       : | `sum_type`+       : | `function_type`+       : | `type_application`++Compound types can be constructed based on the primitive types.  The+Futhark type system is entirely structural, and type abbreviations are+merely shorthands.  The only exception is abstract types whose+definition has been hidden via the module system (see `Module+System`_).++.. productionlist::+   tuple_type: "(" ")" | "(" `type` ("[" "," `type` "]")* ")"++A tuple value or type is written as a sequence of comma-separated+values or types enclosed in parentheses.  For example, ``(0, 1)`` is a+tuple value of type ``(i32,i32)``.  The elements of a tuple need not+have the same type -- the value ``(false, 1, 2.0)`` is of type+``(bool, i32, f64)``.  A tuple element can also be another tuple, as+in ``((1,2),(3,4))``, which is of type ``((i32,i32),(i32,i32))``.  A+tuple cannot have just one element, but empty tuples are permitted,+although they are not very useful.  Empty tuples are written ``()``+and are of type ``()``.++.. productionlist::+   array_type: "[" [`dim`] "]" `type`+   dim: `qualid` | `decimal`++An array value is written as a sequence of zero or more+comma-separated values enclosed in square brackets: ``[1,2,3]``.  An+array type is written as ``[d]t``, where ``t`` is the element type of+the array, and ``d`` is an integer or variable indicating the size.+We can often elide ``d`` and write just ``[]`` (an *anonymous size*),+in which case the size will be inferred.  As an example, an array of+three integers could be written as ``[1,2,3]``, and has type+``[3]i32``.  An empty array is written as ``[]``, and its type is+inferred from its use.  When writing Futhark values for such uses as+``futhark test`` (but not when writing programs), empty arrays are+written ``empty([0]t)`` for an empty array of type ``[0]t``.  When+using ``empty``, all dimensions must be given a size, and at least one+must be zero, e.g. ``empty([2][0]i32)``.++Multi-dimensional arrays are supported in Futhark, but they must be+*regular*, meaning that all inner arrays must have the same shape.+For example, ``[[1,2], [3,4], [5,6]]`` is a valid array of type+``[3][2]i32``, but ``[[1,2], [3,4,5], [6,7]]`` is not, because there+we cannot come up with integers ``m`` and ``n`` such that+``[m][n]i32`` describes the array.  The restriction to regular arrays+is rooted in low-level concerns about efficient compilation.  However,+we can understand it in language terms by the inability to write a+type with consistent dimension sizes for an irregular array value.  In+a Futhark program, all array values, including intermediate (unnamed)+arrays, must be typeable.++.. productionlist::+   sum_type: `constructor` `type`* ("|" `constructor` `type`*)*++Sum types are anonymous in Futhark, and are written as the+constructors separated by vertical bars.  Each constructor consists of+a ``#``-prefixed *name*, followed by zero or more types, called its+*payload*.  **Note:** The current implementation of sum types is+fairly inefficient, in that all possible constructors of a sum-typed+value will be resident in memory.  Avoid using sum types where+multiple constructors have large payloads.++.. productionlist::+   record_type: "{" "}" | "{" `fieldid` ":" `type` ("," `fieldid` ":" `type`)* "}"++Records are mappings from field names to values, with the field names+known statically.  A tuple behaves in all respects like a record with+numeric field names starting from zero, and vice versa.  It is an+error for a record type to name the same field twice.++.. productionlist::+   type_application: `type` `type_arg` | "*" `type`+   type_arg: "[" [`dim`] "]" | `type`++A parametric type abbreviation can be applied by juxtaposing its name+and its arguments.  The application must provide as many arguments as+the type abbreviation has parameters - partial application is+presently not allowed.  See `Type Abbreviations`_ for further details.++.. productionlist::+   function_type: `param_type` "->" `type`+   param_type: `type` | "(" `id` ":" `type` ")"++Functions are classified via function types, but they are not fully+first class.  See :ref:`hofs` for the details.++.. productionlist::+   stringlit: '"' `stringchar` '"'+   stringchar: <any source character except "\" or newline or quotes>++String literals are supported, but only as syntactic sugar for UTF-8+encoded arrays of ``u8`` values.  There is no character type in+Futhark.++Declarations+------------++A Futhark file or module consists of a sequence of declarations.  Each+declaration is processed in order, and a declaration can only refer to+names bound by preceding declarations.++.. productionlist::+   dec:   `fun_bind` | `val_bind` | `type_bind` | `mod_bind` | `mod_type_bind`+      : | "open" `mod_exp`+      : | "import" `stringlit`+      : | "local" `dec`++The ``open`` declaration brings names defined in another module into+scope (see also `Module System`_).  For the meaning of ``import``, see+`Referring to Other Files`_.  If a declaration is prefixed with+``local``, whatever names it defines will *not* be visible outside the+current module.  In particular ``local open`` is used to bring names+from another module into scope, without making those names available+to users of the module being defined.  In most cases, using module+type ascription is a better idea.++Declaring Functions and Values+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++.. productionlist::+   fun_bind:   ("let" | "entry") (`id` | "(" `binop` ")") `type_param`* `pat`+ [":" `type`] "=" `exp`+           : | ("let" | "entry") `pat` `binop` `pat` [":" `type`] "=" `exp`++.. productionlist::+   val_bind: "let" `id` [":" `type`] "=" `exp`++Functions and values must be defined before they are used.  A function+declaration must specify the name, parameters, and body+of the function::++  let name params...: rettype = body++Hindley-Milner-style type inference is supported.  A parameter may be+given a type with the notation ``(name: type)``.  Functions may not be+recursive.  You may put *size annotations* in the return type and+parameter types; see `Size Types`_.  A function can be *polymorphic*+by using type parameters, in the same way as for `Type+Abbreviations`_::++  let reverse [n] 't (xs: [n]t): [n]t = xs[::-1]++Type parameters for a function do not need to cover the types of all+parameters.  The type checker will add more if necessary.  For+example, the following is well typed::++  let pair 'a (x: a) y = (x, y)++A new type variable will be invented for the parameter ``y``.++Shape and type parameters are not passed explicitly when calling+function, but are automatically derived.  If an array value *v* is+passed for a type parameter *t*, all other arguments passed of type+*t* must have the same shape as *v*.  For example, consider the following+definition::++  let pair 't (x: t) (y: t) = (x, y)++The application ``pair [1] [2,3]`` will fail at run-time.++To simplify the handling of in-place updates (see+:ref:`in-place-updates`), the value returned by a function may not+alias any global variables.++User-Defined Operators+~~~~~~~~~~~~~~~~~~~~~~++Infix operators are defined much like functions::++  let (p1: t1) op (p2: t2): rt = ...++For example::++  let (a:i32,b:i32) +^ (c:i32,d:i32) = (a+c, b+d)++We can also define operators by enclosing the operator name in+parentheses and suffixing the parameters, as an ordinary function::++  let (+^) (a:i32,b:i32) (c:i32,d:i32) = (a+c, b+d)++This is necessary when defining a polymorphic operator.++A valid operator name is a non-empty sequence of characters chosen+from the string ``"+-*/%=!><&^"``.  The fixity of an operator is+determined by its first characters, which must correspond to a+built-in operator.  Thus, ``+^`` binds like ``+``, whilst ``*^`` binds+like ``*``.  The longest such prefix is used to determine fixity, so+``>>=`` binds like ``>>``, not like ``>``.++It is not permitted to define operators with the names ``&&`` or+``||`` (although these as prefixes are accepted).  This is because a+user-defined version of these operators would not be short-circuiting.+User-defined operators behave exactly like ordinary functions, except+for being infix.++A built-in operator can be shadowed (i.e. a new ``+`` can be defined).+This will result in the built-in polymorphic operator becoming+inaccessible, except through the ``intrinsics`` module.++An infix operator can also be defined with prefix notation, like an+ordinary function, by enclosing it in parentheses::++  let (+) (x: i32) (y: i32) = x - y++This is necessary when defining operators that take type or shape+parameters.++.. _entry-points:++Entry Points+~~~~~~~~~~~~++Apart from declaring a function with the keyword ``let``, it can also+be declared with ``entry``.  When the Futhark program is compiled any+top-level function declared with ``entry`` will be exposed as an entry+point.  If the Futhark program has been compiled as a library, these+are the functions that will be exposed.  If compiled as an executable,+you can use the ``--entry-point`` command line option of the generated+executable to select the entry point you wish to run.++Any top-level function named ``main`` will always be considered an+entry point, whether it is declared with ``entry`` or not.++Value Declarations+~~~~~~~~~~~~~~~~~~++A named value/constant can be declared as follows::++  let name: type = definition++The definition can be an arbitrary expression, including function+calls and other values, although they must be in scope before the+value is defined.  A constant value may not have a unique type (see+`In-place updates`_).  If the return type contains any anonymous sizes+(see `Size types`_), new existential sizes will be constructed for+them.++Type Abbreviations+~~~~~~~~~~~~~~~~~~++.. productionlist::+   type_bind: "type" ["^" | "~"] `id` `type_param`* "=" `type`+   type_param: "[" `id` "]" | "'" `id` | "'~" `id` | "'^" `id`++Type abbreviations function as shorthands for the purpose of+documentation or brevity.  After a type binding ``type t1 = t2``, the+name ``t1`` can be used as a shorthand for the type ``t2``.  Type+abbreviations do not create distinct types: the types ``t1`` and+``t2`` are entirely interchangeable.++If the right-hand side of a type contains anonymous sizes, it must be+declared "size-lifted" with ``type~``.  If it (potentially) contains a+function, it must be declared "fully lifted" with ``type^``.  A lifted+type can also contain anonymous sizes.  Lifted types cannot be put in+arrays.  Fully lifted types cannot be returned from conditional or+loop expressions.++A type abbreviation can have zero or more parameters.  A type+parameter enclosed with square brackets is a *size parameter*, and+can be used in the definition as an array dimension size, or as a+dimension argument to other type abbreviations.  When passing an+argument for a shape parameter, it must be enclosed in square+brackets.  Example::++  type two_intvecs [n] = ([n]i32, [n]i32)++  let x: two_intvecs [2] = (iota 2, replicate 2 0)++Size parameters work much like shape declarations for arrays.  Like+shape declarations, they can be elided via square brackets containing+nothing.  All size parameters must be used in the definition of the+type abbreviation.++A type parameter prefixed with a single quote is a *type parameter*.+It is in scope as a type in the definition of the type abbreviation.+Whenever the type abbreviation is used in a type expression, a type+argument must be passed for the parameter.  Type arguments need not be+prefixed with single quotes::++  type two_vecs [n] 't = ([n]t, [n]t)+  type two_intvecs [n] = two_vecs [n] i32+  let x: two_vecs [2] i32 = (iota 2, replicate 2 0)++A *size-lifted type parameter* is prefixed with ``'~``, and a *fully+lifted type parameter* with ``'^``.  These have the same rules and+restrictions as lifted type abbreviations.++Expressions+-----------++Expressions are the basic construct of any Futhark program.  An+expression has a statically determined *type*, and produces a *value*+at runtime.  Futhark is an eager/strict language ("call by value").++The basic elements of expressions are called *atoms*, for example+literals and variables, but also more complicated forms.++.. productionlist::+   atom:   `literal`+       : | `qualid` ("." `fieldid`)*+       : | `stringlit`+       : | "(" ")"+       : | "(" `exp` ")" ("." `fieldid`)*+       : | "(" `exp` ("," `exp`)* ")"+       : | "{" "}"+       : | "{" field ("," `field`)* "}"+       : | `qualid` "[" `index` ("," `index`)* "]"+       : | "(" `exp` ")" "[" `index` ("," `index`)* "]"+       : | `quals` "." "(" `exp` ")"+       : | "[" `exp` ("," `exp`)* "]"+       : | "[" `exp` [".." `exp`] "..." `exp` "]"+       : | "(" `qualbinop` ")"+       : | "(" `exp` `qualbinop` ")"+       : | "(" `qualbinop` `exp` ")"+       : | "(" ( "." `field` )+ ")"+       : | "(" "." "[" `index` ("," `index`)* "]" ")"+   exp:   `atom`+      : | `exp` `qualbinop` `exp`+      : | `exp` `exp`+      : | `constructor` `exp`*+      : | `exp` ":" `type`+      : | `exp` ":>" `type`+      : | `exp` [ ".." `exp` ] "..." `exp`+      : | `exp` [ ".." `exp` ] "..<" `exp`+      : | `exp` [ ".." `exp` ] "..>" `exp`+      : | "if" `exp` "then" `exp` "else" `exp`+      : | "let" `pat` "=" `exp` "in" `exp`+      : | "let" `id` "[" `index` ("," `index`)* "]" "=" `exp` "in" `exp`+      : | "let" `id` `type_param`* `pat`+ [":" `type`] "=" `exp` "in" `exp`+      : | "(" "\" `pat`+ [":" `type`] "->" `exp` ")"+      : | "loop" `pat` [("=" `exp`)] `loopform` "do" `exp`+      : | "unsafe" `exp`+      : | "assert" `atom` `atom`+      : | `exp` "with" "[" `index` ("," `index`)* "]" "=" `exp`+      : | `exp` "with" `fieldid` ("." `fieldid`)* "=" `exp`+      : | "match" `exp` ("case" `pat` "->" `exp`)++   field:   `fieldid` "=" `exp`+        : | `id`+   pat:   `id`+      : | `literal`+      : |  "_"+      : | "(" ")"+      : | "(" `pat` ")"+      : | "(" `pat` ("," `pat`)+ ")"+      : | "{" "}"+      : | "{" `fieldid` ["=" `pat`] ["," `fieldid` ["=" `pat`]] "}"+      : | `constructor` `pat`*+      : | `pat` ":" `type`+   loopform :   "for" `id` "<" `exp`+            : | "for" `pat` "in" `exp`+            : | "while" `exp`+   index:   `exp` [":" [`exp`]] [":" [`exp`]]+        : | [`exp`] ":" `exp` [":" [`exp`]]+        : | [`exp`] [":" `exp`] ":" [`exp`]++Some of the built-in expression forms have parallel semantics, but it+is not guaranteed that the the parallel constructs in Futhark are+evaluated in parallel, especially if they are nested in complicated+ways.  Their purpose is to give the compiler as much freedom and+information is possible, in order to enable it to maximise the+efficiency of the generated code.++Resolving Ambiguities+~~~~~~~~~~~~~~~~~~~~~++The above grammar contains some ambiguities, which in the concrete+implementation is resolved via a combination of lexer and grammar+transformations.  For ease of understanding, they are presented here+in natural text.++* An expression ``x.y`` may either be a reference to the name ``y`` in+  the module ``x``, or the field ``y`` in the record ``x``.  Modules+  and values occupy the same name space, so this is disambiguated by+  the type of ``x``.++* A type ascription (``exp : type``) cannot appear as an array+  index, as it conflicts with the syntax for slicing.++* In ``f [x]``, there is am ambiguity between indexing the array ``f``+  at position ``x``, or calling the function ``f`` with the singleton+  array ``x``.  We resolve this the following way:++    * If there is a space between ``f`` and the opening bracket, it is+      treated as a function application.++    * Otherwise, it is an array index operation.++* An expression ``(-x)`` is parsed as the variable ``x`` negated and+  enclosed in parentheses, rather than an operator section partially+  applying the infix operator ``-``.++* The following table describes the precedence and associativity of+  infix operators.  All operators in the same row have the same+  precedence.  The rows are listed in increasing order of precedence.+  Note that not all operators listed here are used in expressions;+  nevertheless, they are still used for resolving ambiguities.++  =================  =============+  **Associativity**  **Operators**+  =================  =============+  left               ``,``+  left               ``:``, ``:>``+  left               ``||``+  left               ``&&``+  left               ``<=`` ``>=`` ``>`` ``<`` ``==`` ``!=``+  left               ``&`` ``^`` ``|``+  left               ``<<`` ``>>``+  left               ``+`` ``-``+  left               ``*`` ``/`` ``%`` ``//`` ``%%``+  left               ``|>``+  right              ``<|``+  right              ``->``+  left               juxtaposition+  =================  =============++.. _patterns:++Patterns+~~~~~~~~++We say that a pattern is *irrefutable* if it can never fail to match a+value of the appropriate type.  Concretely, this means that it does+not require any specific sum type constructor (unless the type in+question has only a single constructor), or any specific numeric or+boolean literal.  Patterns used in function parameters and ``let``+bindings must be irrefutable.  Patterns used in ``case`` need not be+irrefutable.++A pattern ``_`` matches any value.  A pattern consisting of a literal+value (e.g. a numeric constant) matches exactly that value.++Semantics of Simple Expressions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++`literal`+.........++Evaluates to itself.++`qualid`+........++A variable name; evaluates to its value in the current environment.++`stringlit`+...........++Evaluates to an array of type ``[]i32`` that contains the code points+of the characters as integers.++``()``+......++Evaluates to an empty tuple.++``( e )``+.........++Evaluates to the result of ``e``.++``(e1, e2, ..., eN)``+.....................++Evaluates to a tuple containing ``N`` values.  Equivalent to the+record literal ``{0=e1, 1=e2, ..., N-1=eN}``.++``{f1, f2, ..., fN}``+.....................++A record expression consists of a comma-separated sequence of *field+expressions*.  Each field expression defines the value of a field in+the record.  A field expression can take one of two forms:++  ``f = e``: defines a field with the name ``f`` and the value+  resulting from evaluating ``e``.++  ``f``: defines a field with the name ``f`` and the value of the+  variable ``f`` in scope.++Each field may only be defined once.++``a[i]``+........++Return the element at the given position in the array.  The index may+be a comma-separated list of indexes instead of just a single index.+If the number of indices given is less than the rank of the array, an+array is returned.++The array ``a`` must be a variable name or a parenthesised expression.+Furthermore, there *may not* be a space between ``a`` and the opening+bracket.  This disambiguates the array indexing ``a[i]``, from ``a+[i]``, which is a function call with a literal array.++.. _slices:++``a[i:j:s]``+............++Return a slice of the array ``a`` from index ``i`` to ``j``, the+former inclusive and the latter exclusive, taking every ``s``-th+element.  The ``s`` parameter may not be zero.  If ``s`` is negative,+it means to start at ``i`` and descend by steps of size ``s`` to ``j``+(not inclusive).++It is generally a bad idea for ``s`` to be non-constant.+Slicing of multiple dimensions can be done by separating with commas,+and may be intermixed freely with indexing.++If ``s`` is elided it defaults to ``1``.  If ``i`` or ``j`` is elided, their+value depends on the sign of ``s``.  If ``s`` is positive, ``i`` become ``0``+and ``j`` become the length of the array.  If ``s`` is negative, ``i`` becomes+the length of the array minus one, and ``j`` becomes minus one.  This means that+``a[::-1]`` is the reverse of the array ``a``.++In the general case, the size of the array produced by a slice is+unknown (see `Size types`_).  In a few cases, the size is known+statically:++  * ``a[0:n]`` has size ``n``++  * ``a[:n]`` has size ``n``++  * ``a[0:n:1]`` has size ``n``++  * ``a[:n:1]`` has size ``n``++This holds only if ``n`` is a variable or constant.++``[x, y, z]``+.............++Create an array containing the indicated elements.  Each element must+have the same type and shape.++.. _range:++``x..y...z``+............++Construct an integer array whose first element is ``x`` and which+proceeds stride of ``y-x`` until reaching ``z`` (inclusive).  The+``..y`` part can be elided in which case a stride of 1 is used.  A+run-time error occurs if ``z`` is lesser than ``x`` or ``y``, or if+``x`` and ``y`` are the same value.++In the general case, the size of the array produced by a range is+unknown (see `Size types`_).  In a few cases, the size is known+statically:++  * ``1..2...n`` has size ``n``++This holds only if ``n`` is a variable or constant.++.. _range_upto:++``x..y..<z``+............++Construct an integer array whose first elements is ``x``, and which+proceeds upwards with a stride of ``y`` until reaching ``z``+(exclusive).  The ``..y`` part can be elided in which case a stride of+1 is used.  A run-time error occurs if ``z`` is lesser than ``x`` or+``y``, or if ``x`` and ``y`` are the same value.++  * ``0..1..<n`` has size ``n``++  * ``0..<n`` has size ``n``++This holds only if ``n`` is a variable or constant.++``x..y..>z``+...............++Construct an integer array whose first elements is ``x``, and which+proceeds downwards with a stride of ``y`` until reaching ``z``+(exclusive).  The ``..y`` part can be elided in which case a stride of+-1 is used.  A run-time error occurs if ``z`` is greater than ``x`` or+``y``, or if ``x`` and ``y`` are the same value.++``e.f``+........++Access field ``f`` of the expression ``e``, which must be a record or+tuple.++``m.(e)``+.........++Evaluate the expression ``e`` with the module ``m`` locally opened, as+if by ``open``.  This can make some expressions easier to read and+write, without polluting the global scope with a declaration-level+``open``.++``x`` *binop* ``y``+...................++Apply an operator to ``x`` and ``y``.  Operators are functions like+any other, and can be user-defined.  Futhark pre-defines certain+"magical" *overloaded* operators that work on many different types.+Overloaded functions cannot be defined by the user.  Both operands+must have the same type.  The predefined operators and their semantics+are:++  ``**``++    Power operator, defined for all numeric types.++  ``//``, ``%%``++    Division and remainder on integers, with rounding towards zero.++  ``*``, ``/``, ``%``, ``+``, ``-``++    The usual arithmetic operators, defined for all numeric types.+    Note that ``/`` and ``%`` rounds towards negative infinity when+    used on integers - this is different from in C.++  ``^``, ``&``, ``|``, ``>>``, ``<<``++    Bitwise operators, respectively bitwise xor, and, or, arithmetic+    shift right and left, and logical shift right.  Shift amounts+    must be non-negative and the operands must be integers.  Note+    that, unlike in C, bitwise operators have *higher* priority than+    arithmetic operators.  This means that ``x & y == z`` is+    understood as ``(x & y) == z``, rather than ``x & (y == z)`` as+    it would in C.  Note that the latter is a type error in Futhark+    anyhow.++  ``==``, ``!=``++      Compare any two values of builtin or compound type for equality.++  ``<``, ``<=``.  ``>``, ``>=``++      Company any two values of numeric type for equality.++``x && y``+..........++Short-circuiting logical conjunction; both operands must be of type+``bool``.++``x || y``+..........++Short-circuiting logical disjunction; both operands must be of type+``bool``.++``f x``+.......++Apply the function ``f`` to the argument ``x``.++``#c x y z``+............++Apply the sum type constructor ``#x`` to the payload ``x``, ``y``, and+``z``.  A constructor application is always assumed to be saturated,+i.e. its entire payload provided.  This means that constructors may+not be partially applied.++``e : t``+.........++Annotate that ``e`` is expected to be of type ``t``, failing with a+type error if it is not.  If ``t`` is an array with shape+declarations, the correctness of the shape declarations is checked at+run-time.++Due to ambiguities, this syntactic form cannot appear as an array+index expression unless it is first enclosed in parentheses.  However,+as an array index must always be of type ``i32``, there is never a+reason to put an explicit type ascription there.++``e :> t``+..........++Coerce the size of ``e`` to ``t``.  The type of ``t`` must match the+type of ``e``, except that the sizes may be statically different.  At+run-time, it will be verified that the sizes are the same.++``! x``+.......++Logical negation if ``x`` is of type ``bool``.  Bitwise negation if+``x`` is of integral type.++``- x``+.......++Numerical negation of ``x``, which must be of numeric type.++``unsafe e``+............++Elide safety checks and assertions (such as bounds checking) that+occur during execution of ``e``.  This is useful if the compiler is+otherwise unable to avoid bounds checks (e.g. when using indirect+indexes), but you really do not want them there.  Make very sure that+the code is correct; eliding such checks can lead to memory+corruption.++``assert cond e``+.................++Terminate execution with an error if ``cond`` evaluates to false,+otherwise produce the result of evaluating ``e``.  Unless ``e``+produces a value that is used subsequently (it can just be a+variable), dead code elimination may remove the assertion.++``a with [i] = e``+...................++Return ``a``, but with the element at position ``i`` changed to+contain the result of evaluating ``e``.  Consumes ``a``.++``r with f = e``+.................++Return the record ``r``, but with field ``f`` changed to have value+``e``.  The type of the field must remain unchanged.  Type inference+is limited: ``r`` must have a *completely known type* up to ``f``.+This sometimes requires extra type annotations to make the type of+``r`` known.++``if c then a else b``+......................++If ``c`` evaluates to ``true``, evaluate ``a``, else evaluate ``b``.++Binding Expressions+~~~~~~~~~~~~~~~~~~~++``let pat = e in body``+.......................++Evaluate ``e`` and bind the result to the irrefutable pattern ``pat``+(see :ref:`patterns`) while evaluating ``body``.  The ``in`` keyword+is optional if ``body`` is a ``let`` expression.++``let a[i] = v in body``+........................................++Write ``v`` to ``a[i]`` and evaluate ``body``.  The given index need+not be complete and can also be a slice, but in these cases, the value+of ``v`` must be an array of the proper size.  This notation is+Syntactic sugar for ``let a = a with [i] = v in a``.++``let f params... = e in body``+...............................++Bind ``f`` to a function with the given parameters and definition+(``e``) and evaluate ``body``.  The function will be treated as+aliasing any free variables in ``e``.  The function is not in scope of+itself, and hence cannot be recursive.++``loop pat = initial for x in a do loopbody``+.............................................++1. Bind ``pat`` to the initial values given in ``initial``.++2. For each element ``x`` in ``a``, evaluate ``loopbody`` and rebind+   ``pat`` to the result of the evaluation.++3. Return the final value of ``pat``.++The ``= initial`` can be left out, in which case initial values for+the pattern are taken from equivalently named variables in the+environment.  I.e., ``loop (x) = ...`` is equivalent to ``loop (x = x)+= ...``.++``loop pat = initial for x < n do loopbody``+............................................++Equivalent to ``loop (pat = initial) for x in [0..1..<n] do loopbody``.++``loop pat = initial = while cond do loopbody``+...............................................++1. Bind ``pat`` to the initial values given in ``initial``.++2. If ``cond`` evaluates to true, bind ``pat`` to the result of+   evaluating ``loopbody``, and repeat the step.++3. Return the final value of ``pat``.++``match x case p1 -> e1 case p2 -> e2``+.......................................++Match the value produced by ``x`` to each of the patterns in turn,+picking the first one that succeeds.  The result of the corresponding+expression is the value of the entire ``match`` expression.  All the+expressions associated with a ``case`` must have the same type (but+not necessarily match the type of ``x``).  It is a type error if there+is not a ``case`` for every possible value of ``x`` - inexhaustive+pattern matching is not allowed.++Function Expressions+~~~~~~~~~~~~~~~~~~~~++``\x y z: t -> e``+..................++Produces an anonymous function taking parameters ``x``, ``y``, and+``z``, returns type ``t``, and whose body is ``e``.  Lambdas do not+permit type parameters; use a named function if you want a polymorphic+function.++``(binop)``+...........++An *operator section* that is equivalent to ``\x y -> x *binop* y``.++``(x binop)``+.............++An *operator section* that is equivalent to ``\y -> x *binop* y``.++``(binop y)``+.............++An *operator section* that is equivalent to ``\x -> x *binop* y``.++``(.a.b.c)``+............++An *operator section* that is equivalent to ``\x -> x.a.b.c``.++``(.[i,j])``+............++An *operator section* that is equivalent to ``\x -> x[i,j]``.++.. _hofs:++Higher-order functions+----------------------++At a high level, Futhark functions are values, and can be used as any+other value.  However, to ensure that the compiler is able to compile+the higher-order functions efficiently via *defunctionalisation*,+certain type-driven restrictions exist on how functions can be used.+These also apply to any record or tuple containing a function (a+*functional type*):++* Arrays of functions are not permitted.++* A function cannot be returned from an ``if`` expression.++* A ``loop`` parameter cannot be a function.++Further, *type parameters* are divided into *non-lifted* (bound with+an apostrophe, e.g. ``'t``), *size-lifted* (``'~t``), and *fully+lifted* (``'^t``).  Only fully lifted type parameters may be+instantiated with a functional type.  Within a function, a lifted type+parameter is treated as a functional type.++See also `In-place updates`_ for details on how uniqueness types+interact with higher-order functions.++Type Inference+--------------++Futhark supports Hindley-Milner-style type inference, so in many cases+explicit type annotations can be left off.  Record field projection+cannot in isolation be fully inferred, and may need type annotations+where their inputs are bound.  The same goes when constructing sum+types, as Futhark cannot assume that a given constructor only belongs+to a single type.  Further, unique types (see `In-place updates`_)+must be explicitly annotated.++.. _size-types:++Size Types+----------++Futhark supports a simple system of size-dependent types that+statically verifies that the sizes of arrays passed to a function are+compatible.  The focus is on simplicity, not completeness.++Whenever a pattern occurs (in ``let``, ``loop``, and function+parameters), as well as in return types, *size annotations* may be+used to express invariants about the shapes of arrays that are+accepted or produced by the function.  For example::++  let f [n] (a: [n]i32) (b: [n]i32): [n]i32 =+    map (+) a b++We use a *size parameter*, ``[n]``, to explicitly quantify the names+of shapes.  The ``[n]`` parameter is not explicitly passed when+calling ``f``.  Rather, its value is implicitly deduced from the+arguments passed for the value parameters.  An array can contain+*anonymous dimensions*, e.g. ``[]i32``, for which the type checker+will invent fresh size parameters, which ensures that all sizes have a+(symbolic) size.++A size annotation can also be an integer constant (with no suffix).+Size parameters can be used as ordinary variables within the scope of+the parameters.  The type checker verifies that the program obeys any+constraints imposed by size annotations.++*Size-dependent types* are supported, as the names of parameters can+be used in the return type of a function::++  let replicate 't (n: i32) (x: t): [n]t = ...++An application ``replicate 10 0`` will have type ``[10]i32``.++.. _unknown-sizes:++Unknown sizes+~~~~~~~~~~~~~++Since sizes must be constants or variables, there are many cases where+the type checker cannot assign a precise size to the result of some+operation.  For example, the type of ``concat`` should conceptually be::++  val concat [n] [m] 't : [n]t -> [m]t -> [n+m]t++But this is not presently allowed.  Instead, the return type contains+an anonymous size::++  val concat [n] [m] 't : [n]t -> [m]t -> []t++When an application ``concat xs ys`` is found, the result will be of+type ``[k]t``, where ``k`` is a fresh *unknown* size variable that is+considered distinct from every other size in the program.  It is often+necessary to perform a size coercion (see `Size coercion`_) to+convert an unknown size to a known size.++Generally, unknown sizes are constructed whenever the true size cannot+be expressed.  The following lists all possible sources of unknown+sizes.++Size going out of scope+.......................++An unknown size is created when the proper size of an array refers to+a name that has gone out of scope::++  let c = a + b+  in replicate c 0++The type of ``replicate c 0`` is ``[c]i32``, but since ``c`` is+locally bound, the type of the entire expression is ``[k]i32`` for+some fresh ``k``.++Compound expression passed as function argument+...............................................++Intuitively, the type of ``replicate (x+y) 0`` should be ``[x+y]i32``,+but since sizes must be names or constants, this is not expressible.+Therefore an unknown size variable is created and the size of the+expression becomes ``[k]i32``.++Compound expression used as range bound+.......................................++While a simple range expression such as ``0..<n`` can be assigned type+``[n]i32``, a range expression ``0..<(n+1)`` will give produce an+unknown size.++Complex slicing+...............++Most complex array slicing, such as ``xs[a:b]``, will have an unknown+size.  Exceptions are listed in the :ref:`reference for slice+expressions <slices>`.++Complex ranges+..............++Most complex ranges, such as ``a..<b``, will have an known size.+Exceptions exist for :ref:`general ranges <range>` and :ref:`"upto"+ranges <range_upto>`.++Anonymous size in function return type+......................................++Whenever the result of a function application would have an anonymous+size, that size is replaced with a fresh unknown size variable.++For example, ``filter`` has the following type::++  val filter [n] 'a : (p: a -> bool) -> (as: [n]a) -> []a++Naively, an application ``filter f xs`` seems like it would have type+``[]a``, but a fresh unknown size ``k`` will be created and the actual+type will be ``[k]a``.++Branches of ``if`` return arrays of different sizes+...................................................++When an ``if`` (or ``match``) expression has branches that returns+array of different sizes, the differing sizes will be replaced with+fresh unknown sizes.  For example::++  if b then [[1,2], [3,4]]+       else [[5,6]]++This expression will have type ``[k][2]i32``, for some fresh ``k``.++**Important:** The check whether the sizes differ is done when first+encountering the ``if`` or ``match`` during type checking.  At this+point, the type checker may not realise that the two sizes are+actually equal, even though constraints later in the function force+them to be.  This can always be resolved by adding type annotations.++An array produced by a loop does not have a known size+......................................................++If the size of some loop parameter is not maintained across a loop+iteration, the final result of the loop will contain unknown sizes.+For example::++  loop xs = [1] for i < n do xs ++ xs++Similar to conditionals, the type checker may sometimes be too+cautious in assuming that some size may change during the loop.+Adding type annotations to the loop parameter can be used to resolve+this.++Size coercion+~~~~~~~~~~~~~++Size coercion, written with ``:>``, can be used to perform a+runtime-checked coercion of one size to another.  Since size+annotations can refer only to variables and constants, this is+necessary when writing more complicated size functions::++  let concat_to 'a (m: i32) (a: []a) (b: []a) : [m]a =+    a ++ b :> [m]a++Only expression-level type annotations give rise to run-time checks.+Despite their similar syntax, parameter and return type annotations+must be valid at compile-time, or type checking will fail.++Causality restriction+~~~~~~~~~~~~~~~~~~~~~++Conceptually, size parameters are assigned their value by reading the+sizes of concrete values passed along as parameters.  This means that+any size parameter must be used as the size of some parameter.  This+is an error::++  let f [n] (x: i32) = n++The following is not an error::++  let f [n] (g: [n]i32 -> [n]i32) = ...++However, using this function comes with a constraint: whenever an+application ``f x`` occurs, the value of the size parameter must be+inferable.  Specifically, this value must have been used as the size+of an array *before* the ``f x`` application is encountered.  The+notion of "before" is subtle, as there is no evaluation ordering of a+Futhark expression, *except* that a ``let``-binding is always+evaluated before its body, and the argument to a function is always+evaluated before the function.++The causality restriction only occurs when a function has size+parameters whose first use is *not* as a concrete array size.  For+example, it does not apply to uses of the following function::++  let f [n] (arr: [n]i32) (g: [n]i32 -> [n]i32) = ...++This is because the proper value of ``n`` can be read directly from+the actual size of the array.++Empty array literals+~~~~~~~~~~~~~~~~~~~~++Just as with size-polymorphic functions, when constructing an empty+array, we must know the exact size of the (missing) elements.  For+example, in the following program we are forcing the elements of ``a``+to be the same as the elements of ``b``, but the size of the elements+of ``b`` are not known at the time ``a`` is constructed::++  let main (b: bool) (xs: []i32) =+    let a = [] : [][]i32+    let b = [filter (>0) xs]+    in a[0] == b[0]++The result is a type error.++Sum types+~~~~~~~~~++When constructing a value of a sum type, the compiler must still be+able to determine the size of the constructors that are *not* used.+This is illegal::++  type sum = #foo ([]i32) | #bar ([]i32)++  let main (xs: *[]i32) =+    let v : sum = #foo xs+    in xs++Modules+~~~~~~~++When matching a module with a module type (see :ref:`module-system`),+a non-lifted abstract type (i.e. one that is declared with ``type``+rather than ``type^``) may not be implemented by a type abbreviation+that contains any anonymous sizes.  This is to ensure that if we have+the following::++  module m : { type t } = ...++Then we can construct an array of values of type ``m.t`` without+worrying about constructing an irregular array.++Higher-order functions+~~~~~~~~~~~~~~~~~~~~~~++When a higher-order function takes a functional argument whose return+type is a non-lifted type parameter, any instantiation of that type+parameter must have a non-anonymous size.  If the return type is a+lifted type parameter, then the instantiation may contain anonymous+sizes.  This is why the type of ``map`` guarantees regular arrays::++  val map [n] 'a 'b : (a -> b) -> [n]a -> [n]b++The type parameter ``b`` can only be replaced with a type that has+non-anonymous sizes, which means they must be the same for every+application of the function.  In contrast, this is the type of the+pipeline operator::++  val (|>) '^a -> '^b : a -> (a -> b) -> b++The provided function can return something with an anonymous size+(such as ``filter``).++A function whose return type has an unknown size+................................................++If a function (named or anonymous) is inferred to have a return type+that contains an unknown size variable created *within* the function+body, that size variable will be replaced with an anonymous size.  In+most cases this is not important, but it means that an expression like+the following is ill-typed::++  map (\xs -> iota (length xs)) (xss : [n][m]i32)++This is because the ``(length xs)`` expression gives rise to some+fresh size ``k``.  The lambda is then assigned the type ``[n]t ->+[k]i32``, which is immediately turned into ``[n]t -> []i32`` because+``k`` was generated inside its body.  A function of this type cannot+be passed to ``map``, as explained before.  The solution is to bind+``length`` to a name *before* the lambda.++.. _in-place-updates:++In-place Updates+----------------++In-place updates do not provide observable side effects, but they do+provide a way to efficiently update an array in-place, with the+guarantee that the cost is proportional to the size of the value(s)+being written, not the size of the full array.++The ``a with [i] = v`` language construct, and derived forms,+performs an in-place update.  The compiler verifies that the original+array (``a``) is not used on any execution path following the in-place+update.  This involves also checking that no *alias* of ``a`` is used.+Generally, most language constructs produce new arrays, but some+(slicing) create arrays that alias their input arrays.++When defining a function parameter or return type, we can mark it as+*unique* by prefixing it with an asterisk.  For example::++  let modify (a: *[]i32) (i: i32) (x: i32): *[]i32 =+    a with [i] = a[i] + x++For bulk in-place updates with multiple values, use the ``scatter``+function in the basis library.  In the parameter declaration ``a:+*[i32]``, the asterisk means that the function ``modify`` has been+given "ownership" of the array ``a``, meaning that any caller of+``modify`` will never reference array ``a`` after the call again.+This allows the ``with`` expression to perform an in-place update.++After a call ``modify a i x``, neither ``a`` or any variable that+*aliases* ``a`` may be used on any following execution path.++Alias Analysis+~~~~~~~~~~~~~~++The rules used by the Futhark compiler to determine aliasing are+intuitive in the intra-procedural case.  Aliases are associated with+entire arrays.  Aliases of a record are tuple are tracked for each+element, not for the record or tuple itself.  Most constructs produce+fresh arrays, with no aliases.  The main exceptions are ``if``,+``loop``, function calls, and variable literals.++* After a binding ``let a = b``, that simply assigns a new name to an+  existing variable, the variable ``a`` aliases ``b``.  Similarly for+  record projections and patterns.++* The result of an ``if`` aliases the union of the aliases of the+  components.++* The result of a ``loop`` aliases the initial values, as well as any+  aliases that the merge parameters may assume at the end of an+  iteration, computed to a fixed point.++* The aliases of a value returned from a function is the most+  interesting case, and depends on whether the return value is+  declared *unique* (with an asterisk ``*``) or not.  If it is+  declared unique, then it has no aliases.  Otherwise, it aliases all+  arguments passed for *non-unique* parameters.++In-place Updates and Higher-Order Functions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Uniqueness typing generally interacts poorly with higher-order+functions.  The issue is that we cannot control how many times a+function argument is applied, or to what, so it is not safe to pass a+function that consumes its argument.  The following two conservative+rules govern the interaction between uniqueness types and higher-order+functions:++1. In the expression ``let p = e1 in ...``, if *any* in-place update+   takes place in the expression ``e1``, the value bound by ``p`` must+   not be or contain a function.++2. A function that consumes one of its arguments may not be passed as+   a higher-order argument to another function.++.. _module-system:++Module System+-------------++.. productionlist::+   mod_bind: "module" `id` `mod_param`* "=" [":" mod_type_exp] "=" `mod_exp`+   mod_param: "(" `id` ":" `mod_type_exp` ")"+   mod_type_bind: "module" "type" `id` `type_param`* "=" `mod_type_exp`++Futhark supports an ML-style higher-order module system.  *Modules*+can contain types, functions, and other modules and module types.+*Module types* are used to classify the contents of modules, and+*parametric modules* are used to abstract over modules (essentially+module-level functions).  In Standard ML, modules, module types and+parametric modules are called structs, signatures, and functors,+respectively.  Module names exist in the same name space as values,+but module types are their own name space.++Named modules are declared as::++  module name = ...++A named module type is defined as::++  module type name = ...++Where a module expression can be the name of another module, an+application of a parametric module, or a sequence of declarations+enclosed in curly braces::++  module Vec3 = {+    type t = ( f32 , f32 , f32 )+    let add(a: t) (b: t): t =+      let (a1, a2, a3) = a in+      let (b1, b2, b3) = b in+      (a1 + b1, a2 + b2 , a3 + b3)+  }++  module AlsoVec3 = Vec3++Functions and types within modules can be accessed using dot+notation::++    type vector = Vec3.t+    let double(v: vector): vector = Vec3.add v v++We can also use ``open Vec3`` to bring the names defined by ``Vec3``+into the current scope.  Multiple modules can be opened simultaneously+by separating their names with spaces.  In case several modules define+the same names, the ones mentioned last take precedence.  The first+argument to ``open`` may be a full module expression.++Named module types are defined as::++  module type ModuleTypeName = ...++A module type expression can be the name of another module type, or a+sequence of *specifications*, or *specs*, enclosed in curly braces.  A+spec can be a *value spec*, indicating the presence of a function or+value, an *abstract type spec*, or a *type abbreviation spec*.  For+example::++  module type Addable = {+    type t                 -- abstract type spec+    type two_ts = (t,t)    -- type abbreviation spec+    val add: t -> t -> t   -- value spec+  }++This module type specifies the presence of an *abstract type* ``t``,+as well as a function operating on values of type ``t``.  We can use+*module type ascription* to restrict a module to what is exposed by+some module type::++  module AbstractVec = Vec3 : Addable++The definition of ``AbstractVec.t`` is now hidden.  In fact, with this+module type, we can neither construct values of type ``AbstractVec.T``+or convert them to anything else, making this a rather useless use of+abstraction.  As a derived form, we can write ``module M: S = e`` to+mean ``module M = e : S``.++In a value spec, sizes in types on the left-hand side of a function+arrow must not be anonymous.  For example, this is forbidden::++  val sum: []t -> t++Instead write::++  val sum [n]: [n]t -> t++But this is allowed, because the empty size is not to the left of a+function arrow::++  val evens [n]: [n]i32 -> []i32++Parametric modules allow us to write definitions that abstract over+modules.  For example::++  module Times = \(M: Addable) -> {+    let times (x: M.t) (k: int): M.t =+      loop (x' = x) for i < k do+        T.add x' x+  }++We can instantiate ``Times`` with any module that fulfils the module+type ``Addable`` and get back a module that defines a function+``times``::++  module Vec3Times = Times Vec3++Now ``Vec3Times.times`` is a function of type ``Vec3.t -> int ->+Vec3.t``.  As a derived form, we can write ``module M p = e`` to mean+``module M = \p -> e``.++Module Expressions+~~~~~~~~~~~~~~~~~~++.. productionlist::+   mod_exp:   `qualid`+          : | `mod_exp` ":" `mod_type_exp`+          : | "\" "(" `id` ":" `mod_type_exp` ")" [":" `mod_type_exp`] "->" `mod_exp`+          : | `mod_exp` `mod_exp`+          : | "(" `mod_exp` ")"+          : | "{" `dec`* "}"+          : | "import" `stringlit`++A module expression produces a module.  Modules are collections of+bindings produced by declarations (`dec`).  In particular, a module+may contain other modules or module types.++``qualid``+..........++Evaluates to the module of the given name.++``(mod_exp)``+.............++Evaluates to ``mod_exp``.++``mod_exp : mod_type_exp``+..........................++*Module ascription* evaluates the module expression and the module+type expression, verifies that the module implements the module type,+then returns a module that exposes only the functionality described by+the module type.  This is how internal details of a module can be+hidden.++``\(p: mt1): mt2 -> e``+.......................++Constructs a *parametric module* (a function at the module level) that+accepts a parameter of module type ``mt1`` and returns a module of+type ``mt2``.  The latter is optional, but the parameter type is not.++``e1 e2``+.........++Apply the parametric module ``m1`` to the module ``m2``.++``{ decs }``+............++Returns a module that contains the given definitions.  The resulting+module defines any name defined by any declaration that is not+``local``, *in particular* including names made available via+``open``.++``import "foo"``+................++Returns a module that contains the definitions of the file ``"foo"``+relative to the current file.  See :ref:`other-files`.++Module Type Expressions+~~~~~~~~~~~~~~~~~~~~~~~++.. productionlist::+   mod_type_exp:   `qualid`+             : | "{" `spec`* "}"+             : | `mod_type_exp` "with" `qualid` `type_param`* "=" `type`+             : | "(" `mod_type_exp` ")"+             : | "(" `id` ":" `mod_type_exp` ")" "->" `mod_type_exp`+             : | `mod_type_exp` "->" `mod_type_exp`+++.. productionlist::+   spec:   "val" `id` `type_param`* ":" `spec_type`+       : | "val" `binop` `type_param`* ":" `spec_type`+       : | "type" ["^"] `id` `type_param`* "=" `type`+       : | "type" ["^"] `id` `type_param`*+       : | "module" `id` ":" `mod_type_exp`+       : | "include" `mod_type_exp`+   spec_type: `type` | `type` "->" `spec_type`++Module types classify modules, with the only (unimportant) difference+in expressivity being that modules can contain module types, but+module types cannot specify that a module must contain a specific+module type. They can specify of course that a module contains a+*submodule* of a specific module type.++.. _other-files:++Referring to Other Files+------------------------++You can refer to external files in a Futhark file like this::++  import "file"++The above will include all non-``local`` top-level definitions from+``file.fut`` is and make them available in the current file (but+will not export them).  The ``.fut`` extension is implied.++You can also include files from subdirectories::++  import "path/to/a/file"++The above will include the file ``path/to/a/file.fut`` relative to the+including file.++Qualified imports are also possible, where a module is created for the+file::++  module M = import "file"++In fact, a plain ``import "file"`` is equivalent to::++  local open import "file"
docs/man/futhark-bench.rst view
@@ -76,6 +76,10 @@      futhark bench prog.fut --backend=opencl --pass-option=-dHawaii +--pass-compiler-option=opt++  Pass an extra option to the compiler when compiling the programs.+ --runner=program    If set to a non-empty string, compiled programs are not run
docs/man/futhark-c.rst view
@@ -51,6 +51,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-csharp.rst view
@@ -49,6 +49,9 @@   error, the result of the last successful compiler step will be   printed to standard error. +-W+  Do not print any warnings.+ -V   Print version information on standard output and exit.
docs/man/futhark-csopencl.rst view
@@ -51,6 +51,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-cuda.rst view
@@ -53,6 +53,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-opencl.rst view
@@ -53,6 +53,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-pyopencl.rst view
@@ -60,6 +60,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-python.rst view
@@ -54,6 +54,9 @@ -V   Print version information on standard output and exit. +-W+  Do not print any warnings.+ --Werror   Treat warnings as errors.
docs/man/futhark-test.rst view
@@ -160,7 +160,11 @@   Pass an option to benchmark programs that are being run.  For   example, we might want to run OpenCL programs on a specific device:: -    futhark-bench prog.fut --backend=opencl --pass-option=-dHawaii+    futhark test prog.fut --backend=opencl --pass-option=-dHawaii++--pass-compiler-option=opt++  Pass an extra option to the compiler when compiling the programs.  --runner=program
docs/man/futhark.rst view
@@ -24,10 +24,11 @@ COMMANDS ======== -futhark check PROGRAM----------------------+futhark check [-w] PROGRAM+-------------------------- -Check whether a Futhark program type checks.+Check whether a Futhark program type checks.  With ``-w``, no warnings+are printed.  futhark datacmp FILE_A FILE_B -----------------------------
+ docs/package-management.rst view
@@ -0,0 +1,361 @@+.. _package-management:++Package Management+==================++This document describes ``futhark pkg``, a minimalistic package+manager inspired by `vgo <https://research.swtch.com/vgo>`_.  A+Futhark package is a downloadable collection of ``.fut`` files and+little more.  There is a (not necessarily comprehensive) `list of+known packages <https://futhark-lang.org/pkgs>`_.++Basic Concepts+--------------++A package is uniquely identified with a *package path*, which is+similar to a URL, except without a protocol.  At the moment, package+paths are always links to Git repositories hosted on GitHub or GitLab.+In the future, this will become more flexible.  As an example, a+package path may be ``github.com/athas/fut-foo``.++Packages are versioned with `semantic version numbers+<https://semver.org/>`_ of the form ``X.Y.Z``.  Whenever versions are+indicated, all three digits must always be given (that is, ``1.0`` is+not a valid shorthand for ``1.0.0``).++Most ``futhark pkg`` operations involve reading and writing a *package+manifest*, which is always stored in a file called ``futhark.pkg``.+The ``futhark.pkg`` file is human-editable, but is in day-to-day use+mainly modified by ``futhark pkg`` automatically.++Using Packages+--------------++Required packages can be added by using ``futhark pkg add``, for example::++  $ futhark pkg add github.com/athas/fut-foo 0.1.0++This will create a new file ``futhark.pkg`` with the following contents:++.. code-block:: text++   require {+     github.com/athas/fut-foo 0.1.0 #d285563c25c5152b1ae80fc64de64ff2775fa733+   }++This lists one required package, with its package path, minimum+version (see :ref:`version-selection`), and the expected commit hash.+The latter is used for verification, to ensure that the contents of a+package version cannot be changed silently.++``futhark pkg`` will perform network requests to determine whether a+package of the given name and with the given version exists and fail+otherwise (but it will not check whether the package is otherwise+well-formed).  The version number can be elided, in which case+``futhark pkg`` will use the newest available version.  If the package+is already present in ``futhark.pkg``, it will simply have its version+requirement changed to the one specified in the command.  Any+dependencies of the package will *not* be added to ``futhark.pkg``,+but will still be downloaded by ``futhark pkg sync`` (see below).++Adding a package with ``futhark pkg add`` modifies ``futhark.pkg``,+but does not download the package files.  This is done with+``futhark pkg sync`` (without further options).  The contents of each+required dependency and any transitive dependencies will be stored in+a subdirectory of ``lib/`` corresponding to their package path.  As an+example::++  $ futhark pkg sync+  $ tree lib+  lib+  └── github.com+      └── athas+          └── fut-foo+              └── foo.fut++  3 directories, 1 file++**Warning:** ``futhark pkg sync`` will remove any unrecognized files or+local modifications to files in ``lib/`` (except of course the package+directory of the package path listed in ``futhark.pkg``; see+:ref:`creating-packages`).++Packages can be removed from ``futhark.pkg`` with::++  $ futhark pkg remove pkgpath++You will need to run ``futhark pkg sync`` to actually remove the files in+``lib/``.++The intended usage is that ``futhark.pkg`` is added to version+control, but ``lib/`` is not, as the contents of ``lib/`` can always+be reproduced from ``futhark.pkg``.  However, adding ``lib/`` works+just fine as well.++Importing Files from Dependencies+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++``futhark pkg sync`` will populate the ``lib/`` directory, but does+not interact with the compiler in any way.  The downloaded files can+be imported using the usual ``import`` mechanism (:ref:`other-files`);+for example, assuming the package contains a file ``foo.fut``::++  import "lib/github.com/athas/fut-foo/foo"++Ultimately, everything boils down to ordinary file system semantics.+This has the downside of relatively long and clumsy import paths, but+the upside of predictability.++Upgrading Dependencies+~~~~~~~~~~~~~~~~~~~~~~++The ``futhark pkg upgrade`` command will update every version+requirement in ``futhark.pkg`` to be the most recent available+version.  You still need to run ``futhark pkg sync`` to actually+retrieve the new versions.  Be careful - while upgrades are safe if+semantic versioning is followed correctly, this is not yet properly+machine-checked, so human mistakes may occur.++As an example:++.. code-block:: text++   $ cat futhark.pkg+   require {+     github.com/athas/fut-foo 0.1.0 #d285563c25c5152b1ae80fc64de64ff2775fa733+   }+   $ futhark pkg upgrade+   Upgraded github.com/athas/fut-foo 0.1.0 => 0.2.1.+   $ cat futhark.pkg+   require {+     github.com/athas/fut-foo 0.2.1 #3ddc9fc93c1d8ce560a3961e55547e5c78bd0f3e+   }+   $ futhark pkg sync+   $ tree lib+   lib+   └── github.com+       └── athas+           ├── fut-bar+           │   └── bar.fut+           └── fut-foo+               └── foo.fut++   4 directories, 2 files++Note that ``fut-foo 0.2.1`` depends on ``github.com/athas/fut-bar``,+so it was fetched by ``futhark pkg sync``.++``futhark pkg upgrade`` will *never* upgrade across a major version+number.  Due to the principle of `Semantic Import Versioning+<https://research.swtch.com/vgo-import>`_, a new major version is a+completely different package from the point of view of the package+manager.  Thus, to upgrade to a new major version, you will need to+use ``futhark pkg add`` to add the new version and ``futhark pkg+remove`` to remove the old version.  Or you can keep it around - it is+perfectly acceptable to depend on multiple major versions of the same+package, because they are really different packages.++.. _creating-packages:++Creating Packages+-----------------++A package is a directory tree (which at the moment must correspond to+a Git repository).  It *must* contain two things:++  * A file ``futhark.pkg`` at the root defining the package path and+    any required packages.++  * A *package directory* ``lib/pkg-path``, where ``pkg-path`` is the+    full package path.++The contents of the package directory is what will be made available+to users of the package.  The repository may contain other things+(tests, data files, examples, docs, other programs, etc), but these+are ignored by ``futhark pkg``.  This structure can be created+automatically by running for example::++  $ futhark pkg init github.com/sturluson/edda++Note again, no ``https://``.  The result is this ``futhark.pkg``::++  package github.com/sturluson/edda++  require {+  }++And this file hierarchy:++.. code-block:: text++   $ tree lib+   lib+   └── github.com+       └── sturluson+           └── edda++   3 directories, 0 files++Note that ``futhark pkg init`` is not necessary simply to *use*+packages, only when *creating* packages.++When creating a package, the ``.fut`` files we are writing will be+located inside the ``lib/`` directory.  If the package has its own+dependencies, whose files we would like to access, we can use+*relative imports*.  For example, assume we are creating a package+``github.com/sturluson/edda`` and we are writing a Futhark file+located at ``lib/github.com/sturluson/edda/saga.fut``.  Further, we+have a dependency on the package ``github.com/athas/foo-fut``, which+is stored in the directory ``lib/github.com/athas/foo-fut``.  We can+import a file ``lib/github.com/athas/foo-fut/foo.fut`` from+``lib/github.com/sturluson/edda/saga.fut`` with::++  import "../foo-fut/foo"++Releasing a Package+~~~~~~~~~~~~~~~~~~~++Currently, a package corresponds exactly to a GitHub repository+mirroring the package path.  A release is done by tagging an+appropriate commit with ``git tag vX.Y.Z`` and then pushing the tag to+GitHub with ``git push --tags``.  In the future, this will be+generalised to other code hosting sites and version control systems+(and possibly self-hosted tarballs).  Remember to take semantic+versioning into account - unless you bump the major version number (or+the major version is 0), the new version must be *fully compatible*+with the old.++When releasing a new package, consider getting it added to the+`central package list <https://futhark-lang.org/pkgs>`_.  See `this+page+<https://github.com/diku-dk/futhark-docbot/blob/master/README.md>`_+for details.++Incrementing the Major Version Number+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++While backwards-incompatible modifications to a package are sometimes+unavoidable, it is wise to avoid them as much as possible, as they+significantly inconvenience users.  To discourage breaking+compatibility, ``futhark pkg`` tries to ensure that the package+developer feels this inconvenience as well.  In many cases, an+incompatible change can be avoided simply by adding new files to the+package rather than incompatibly changing the existing ones.++In the general case, the package path also encodes the major version+of the package, separated with a ``@``.  For example, version 5.2.1 of+a package might have the package path ``github.com/user/repo@5``.  For+major versions 0 and 1, this can be elided.  This means that multiple+(major) versions of a package are completely distinct from the point+of view of the package manager - this principle is called `Semantic+Import Versioning <https://research.swtch.com/vgo-import>`_, and is+intended to facilitate backwards compatibility of packages when new+versions are released.++If you really must increment the major version, then you will need to+change the package path in ``futhark.pkg`` to contain the new major+version preceded by ``@``.  For example,+``lib/github.com/sturluson/edda`` becomes+``lib/github.com/sturluson/edda@2``.  As a special case, this is not+necessary when moving from major version 0 to 1.  Since the package+path has changed, you will also need to rename the package directory+in ``lib/``.  This is painful and awkward, but it is less painful and+awkward than what users feel when their dependencies break+compatibility.++Renaming a Package+~~~~~~~~~~~~~~~~~~++It is likely that the hosting location for a very long-lived package+will change from time to time.  Since the hosting location is embedded+into the package path itself, this causes some issues for+``futhark pkg``.++In simple cases, there is no problem.  Consider a package+``github.com/asgard/loki`` which is moved to+``github.com/utgard/loki``.  If no GitHub-level redirect is set up,+all users must update the path by which they import the package.  This+is unavoidable, unfortunately.++However, the old tagged versions, which contain a ``futhark.pkg`` that+uses the old package path, will continue to work.  This is because the+package path indicated in ``package.pkg`` merely defines the+subdirectory of ``lib/`` where the package files are to be found,+while the package path used by dependents in the ``require`` section+defines where the package files are located after ``futhark pkg+sync``.  Thus, when we import an old version of+``github.com/utgard/loki`` whose ``futhark.pkg`` defines the package+as ``github.com/asgard/loki``, the package files will be retrieved+from the ``lib/github.com/asgard/loki`` directory in the repository,+but stored at ``lib/github.com/utgard/loki`` in the local directory.++The above means that package management remains operational in simple+cases of renaming, but it is awkward when a transitive dependency is+renamed (or deleted).  The Futhark package ecosystem is sufficiently+embryonic that we have not yet developed more robust solutions.  When+such solutions are developed, they will likely involve some form of+``replace`` directive that allows transparent local renaming of+packages, as well as perhaps a central registry of package paths that+does not depend on specific source code hosts.++.. _version-selection:++Version Selection+-----------------++The package manifest ``futhark.pkg`` declares which packages the+program depends on.  Dependencies are specified as the *oldest+acceptable version* within the given major version.  Upper version+bounds are not supported, as strict adherence to semantic versioning+is assumed, so any later version with the same major version number+should work.  When ``futhark pkg sync`` calculates which version of a+given package to download, it will pick the oldest version that still+satisfies the minimum version requirements of that package in all+transitive dependencies.  This means that a version may be used that+is newer than the one indicated in ``futhark.pkg``, but only if a+dependency requires a more recent version.++Tests and Documentation for Dependencies+----------------------------------------++Package management has been designed to ensure that the normal+development tools work as expected with the contents of the ``lib/``+directory.  For example, to ensure that all dependencies do in fact+work well (or at least compile) together, run:++.. code-block:: text++   futhark test lib++Also, you can generate hyperlinked documentation for all dependencies+with:++.. code-block:: text++   futhark doc lib -o docs++The file ``docs/index.html`` can be opened in a web browser to browse+the documentation.  Prebuilt documentation is also available via the+`online package list <https://futhark-lang.org/pkgs>`_.++Safety+------++In contrast to some other package managers, ``futhark pkg`` does not+run any package-supplied code on installation, upgrade, or removal.+This means that all ``futhark pkg`` operations are in principle+completely safe (barring exploitable bugs in ``futhark pkg`` itself,+which is unlikely but not impossible).  Further, Futhark code itself+is also completely pure, so executing it cannot have any unfortunate+effects, such as `infecting all of your own packages with a worm+<https://jamie.build/how-to-build-an-npm-worm>`_.  The worst it can do+is loop infinitely, consume arbitrarily large amounts of memory, or+produce wrong results.++The exception is packages that uses ``unsafe``.  With some cleverness,+``unsafe`` can be combined with in-place updates to perform arbitrary+memory reads and writes, which can trivially lead to exploitable+behaviour.  You should not use untrusted code that employs ``unsafe``+(but the ``--safe`` compiler option may help).  However, this is not+any worse than calling external code in a conventional impure+language, which generally can perform any conceivable harmful action.
+ docs/requirements.txt view
@@ -0,0 +1,1 @@+pyyaml>=4.2b1
+ docs/usage.rst view
@@ -0,0 +1,457 @@+.. _usage:++Basic Usage+===========++Futhark contains several code generation backends.  Each is provided+as subcommand of the ``futhark`` binary.  For example, ``futhark c``+compiles a Futhark program by translating it to sequential C code,+while ``futhark pyopencl`` generates Python code with calls to the+PyOpenCL library.  The different compilers all contain the same+frontend and optimisation pipeline - only the code generator is+different.  They all provide roughly the same command line interface,+but there may be minor differences and quirks due to characteristics+of the specific backends.++There are two main ways of compiling a Futhark program: to an+executable (by using ``--executable``, which is the default), and to a+library (``--library``).  Executables can be run immediately, but are+useful mostly for testing and benchmarking.  Libraries can be called+from non-Futhark code.++Compiling to Executable+-----------------------++A Futhark program is stored in a file with the extension ``.fut``.  It+can be compiled to an executable program as follows::++  $ futhark c prog.fut++This makes use of the ``futhark c`` compiler, but any other will work+as well.  The compiler will automatically invoke ``gcc`` to produce an+executable binary called ``prog``.  If we had used ``futhark py``+instead of ``futhark c``, the ``prog`` file would instead have+contained Python code, along with a `shebang`_ for easy execution.  In+general, when compiling file ``foo.fut``, the result will be written+to a file ``foo`` (i.e. the extension will be stripped off).  This can+be overridden using the ``-o`` option.  For more details on specific+compilers, see their individual manual pages.++.. _shebang: https://en.wikipedia.org/wiki/Shebang_%28Unix%29++Executables generated by the various Futhark compilers share a common+command-line interface, but may also individually support more+options.  When a Futhark program is run, execution starts at one of+its *entry points*.  By default, the entry point named ``main`` is+run.  An alternative entry point can be indicated by using the ``-e``+option.  All entry point functions must be declared appropriately in+the program (see :ref:`entry-points`).  If the entry point takes any+parameters, these will be read from standard input in a subset of the+Futhark syntax.  A binary input format is also supported; see+:ref:`binary-data-format`.  The result of the entry point is printed+to standard output.++Only a subset of all Futhark values can be passed to an executable.+Specifically, only primitives and arrays of primitive types are+supported.  In particular, nested tuples and arrays of tuples are not+permitted.  Non-nested tuples are supported are supported as simply+flat values.  This restriction is not present for Futhark programs+compiled to libraries.  If an entry point *returns* any such value,+its printed representation is unspecified.  As a special case, an+entry point is allowed to return a flat tuple.++Instead of compiling, there is also an interpreter, accessible as+``futhark run`` and ``futhark repl``.  The latter is an interactive+prompt, useful for experimenting with Futhark expressions.  Be aware+that the interpreter runs code very slowly.+++.. _executable-options:++Executable Options+^^^^^^^^^^^^^^^^^^++All generated executables support the following options.++  ``-t FILE``++    Print the time taken to execute the program to the indicated file,+    an integral number of microseconds.  The time taken to perform setup+    or teardown, including reading the input or writing the result, is+    not included in the measurement.  See the documentation for specific+    compilers to see exactly what is measured.++  ``-r RUNS``++    Run the specified entry point the given number of times (plus a+    warmup run).  The program result is only printed once, after the+    last run.  If combined with ``-t``, one measurement is printed per+    run.  This is a good way to perform benchmarking.++  ``-D``++    Print debugging information on standard error.  Exactly what is+    printed, and how it looks, depends on which Futhark compiler is+    used.  This option may also enable more conservative (and slower)+    execution, such as frequently synchronising to check for errors.++  ``-b``++    Print the result using the binary data format+    (:ref:`binary-data-format`).  For large outputs, this is+    significantly faster and takes up less space.++Parallel Options+~~~~~~~~~~~~~~~~++The following options are supported by executables generated with the+parallel backends (``opencl``, ``pyopencl``, ``csopencl``, and+``cuda``).++  ``--tuning=FILE``++    Load tuning options from the indicated *tuning file*.  The file+    must contain lines of the form ``SIZE=VALUE``, where each *SIZE*+    must be one of the sizes listed by the ``--print-sizes`` option+    (without size class), and the *VALUE* must be a non-negative+    integer.  Extraneous spaces or blank lines are not allowed.  A zero+    means to use the default size, whatever it may be.  In case of+    duplicate assignments to the same size, the last one takes+    predecence.  This is equivalent to passing each size setting on+    the command like using the ``--size`` option, but more convenient.++  ``--print-sizes``++    Print a list of tunable sizes followed by their *size class* in+    parentheses, which indicates what they are used for.++  ``--size=SIZE=VALUE``++    Set one of the tunable sizes to the given value.  Using the+    ``--tuning`` option is more convenient.++OpenCL-specific Options+~~~~~~~~~~~~~~~~~~~~~~~++The following options are supported by executables generated with the+OpenCL backends (``opencl``, ``pyopencl``, and ``csopencl``):++  ``-P``++    Measure the time taken by various OpenCL operations (such as+    kernels) and print a summary at the end.  Unfortunately, it is+    currently nontrivial (and manual) to relate these operations back+    to source Futhark code.++  ``-p PLATFORM``++    Pick the first OpenCL platform whose name contains the given+    string.  The special string ``#k``, where ``k`` is an integer, can+    be used to pick the *k*-th platform, numbered from zero.++  ``-d DEVICE``++    Pick the first OpenCL device whose name contains the given string.+    The special string ``#k``, where ``k`` is an integer, can be used+    to pick the *k*-th device, numbered from zero.  If used in+    conjunction with ``-p``, only the devices from matching platforms+    are considered.++  ``--default-group-size INT``++    The default size of OpenCL workgroups that are launched.  Capped+    to the hardware limit if necessary.++  ``--default-num-groups INT``++    The default number of OpenCL workgroups that are launched.++  ``--dump-opencl FILE``++    Don't run the program, but instead dump the embedded OpenCL+    program to the indicated file.  Useful if you want to see what is+    actually being executed.++  ``--load-opencl FILE``++    Instead of using the embedded OpenCL program, load it from the+    indicated file.  This is extremely unlikely to result in succesful+    execution unless this file is the result of a previous call to+    ``--dump-opencl`` (perhaps lightly modified).++  ``--dump-opencl-binary FILE``++    Don't run the program, but instead dump the compiled version of+    the embedded OpenCL program to the indicated file.  On NVIDIA+    platforms, this will be PTX code.  If this option is set, no entry+    point will be run.++  ``--load-opencl-binary FILE``++    Load an OpenCL binary from the indicated file.++  ``--build-option OPT``++    Add an additional build option to the string passed to+    ``clBuildProgram()``.  Refer to the OpenCL documentation for which+    options are supported.  Be careful - some options can easily+    result in invalid results.++There is rarely a need to use both ``-p`` and ``-d``.  For example, to+run on the first available NVIDIA GPU, ``-p NVIDIA`` is sufficient, as+there is likely only a single device associated with this platform.+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.++CUDA-specific Options+~~~~~~~~~~~~~~~~~~~~~++The following options are supported by executables generated by the+``cuda`` backend:++  ``--dump-cuda FILE``++    Don't run the program, but instead dump the embedded CUDA program+    to the indicated file.  Useful if you want to see what is actually+    being executed.++  ``--load-cuda FILE``++    Instead of using the embedded CUDA program, load it from the+    indicated file.  This is extremely unlikely to result in succesful+    execution unless this file is the result of a previous call to+    ``--dump-cuda`` (perhaps lightly modified).++  ``--dump-ptx FILE``++    As ``--dump-cuda``, but dumps the compiled PTX code instead.++  ``--load-ptx FILE``++    Instead of using the embedded CUDA program, load compiled PTX code+    from the indicated file.++  ``--nvrtc-option=OPT``++    Add the given option to the command line used to compile CUDA+    kernels with NVRTC.  The list of supported options varies with the+    CUDA version but can be `found in the NVRTC+    documentation+    <https://docs.nvidia.com/cuda/nvrtc/index.html#group__options>`_.++For convenience, CUDA executables also accept the same+``--default-num-groups`` and ``--default-group-size`` options that the+OpenCL backend uses.  These then refer to grid size and thread block+size, respectively.++Compiling to Library+--------------------++While compiling a Futhark program to an executable is useful for+testing, it is not suitable for production use.  Instead, a Futhark+program should be compiled into a reusable library in some target+language, enabling integration into a larger program.  Five of the+Futhark compilers support this: ``futhark c``, ``futhark opencl``,+``futhark cuda``, ``futhark py``, and ``futhark pyopencl``.++General Concerns+^^^^^^^^^^^^^^^^++Futhark entry points are mapped to some form of function or method in+the target language.  Generally, an entry point taking *n* parameters+will result in a function taking *n* parameters.  Extra parameters may+be added to pass in context data, or *out*-parameters for writing the+result, for target languages that do not support multiple return+values from functions.++Not all Futhark types can be mapped cleanly to the target language.+Arrays of tuples, for example, are a common issue.  In such cases, *opaque+types* are used in the generated code.  Values of these types cannot+be directly inspected, but can be passed back to Futhark entry points.+In the general case, these types will be named with a random hash.+However, if you insert an explicit type annotation (and the type+name contains only characters valid for identifiers for the used+backend), the indicated name will be used.  Note that arrays contain+brackets, which are usually not valid in identifiers.  Defining a+simple type alias is the best way around this.++Generating C+^^^^^^^^^^^^++A Futhark program ``futlib.fut`` can be compiled to reusable C code+using either::++  $ futhark c --library futlib.fut++Or::++  $ futhark opencl --library futlib.fut++This produces two files in the current directory: ``futlib.c`` and+``futlib.h``.  If we wish (and are on a Unix system), we can then+compile ``futlib.c`` to an object file like this::++  $ gcc futlib.c -c++This produces a file ``futlib.o`` that can then be linked with the+main application.  Details of how to link the generated code with+other C code is highly system-dependent, and outside the scope of this+manual.  On Unix, we can simply add ``futlib.o`` to the final compiler+or linker command line::++  $ gcc main.c -o main futlib.o++Depending on the Futhark backend you are using, you may need to add+some linker flags.  For example, ``futhark opencl`` requires+``-lOpenCL`` (``-framework OpenCL`` on macOS).  See the manual page+for each compiler for details.++It is also possible to simply add the generated ``.c`` file to the C+compiler command line used for compiling our whole program (here+``main.c``)::++  $ gcc main.c -o main futlib.c++The downside of this approach is that the generated ``.c`` file may+contain code that causes the C compiler to warn (for example, unused+support code that is not needed by the Futhark program).++The generated header file (here, ``futlib.h``) specifies the API, and+is intended to be human-readable.  The basic usage revolves around+creating a *configuration object*, which can then be used to obtain a+*context object*, which must be passed whenever entry points are+called.++The configuration object is created using the following function::++  struct futhark_context_config *futhark_context_config_new();++Depending on the backend, various functions are generated to modify+the configuration.  The following is always available::++  void futhark_context_config_set_debugging(struct futhark_context_config *cfg,+                                            int flag);++A configuration object can be used to create a context with the+following function::++  struct futhark_context *futhark_context_new(struct futhark_context_config *cfg);++Memory management is entirely manual.  Deallocation functions are+provided for all types defined in the header file.  Everything+returned by an entry point must be manually deallocated.++Functions that can fail return an integer: 0 on success and a non-zero+value on error.  A human-readable string describing the error can be+retrieved with the following function::++  char *futhark_context_get_error(struct futhark_context *ctx);++It is the caller's responsibility to ``free()`` the returned string.+Any subsequent call to the function returns ``NULL``, until a new+error occurs.++For now, many internal errors, such as failure to allocate memory,+will cause the function to ``abort()`` rather than return an error+code.  However, all application errors (such as bounds and array size+checks) will produce an error code.++The API functions are thread safe.++C with OpenCL+~~~~~~~~~~~~~++When generating C code with ``futhark opencl``, you will need to link+against the OpenCL library when linking the final binary::++  $ gcc main.c -o main futlib.o -lOpenCL++When using the OpenCL backend, extra API functions are provided for+directly accessing or providing the OpenCL objects used by Futhark.+Take care when using these functions.  In particular, a Futhark+context can now be provided with the command queue to use::++  struct futhark_context *futhark_context_new_with_command_queue(struct futhark_context_config *cfg, cl_command_queue queue);++As a ``cl_command_queue`` specifies an OpenCL device, this is also how+manual platform and device selection is possible.  A function is also+provided for retrieving the command queue used by some Futhark+context::++  cl_command_queue futhark_context_get_command_queue(struct futhark_context *ctx);++This can be used to connect two separate Futhark contexts that have+been loaded dynamically.++The raw ``cl_mem`` object underlying a Futhark array can be accessed+with the function named ``futhark_values_raw_type``, where ``type``+depends on the array in question.  For example::++  cl_mem futhark_values_raw_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr);++The array will be stored in row-major form in the returned memory+object.  The function performs no copying, so the ``cl_mem`` still+belongs to Futhark, and may be reused for other purposes when the+corresponding array is freed.  A dual function can be used to+construct a Futhark array from a ``cl_mem``::++  struct futhark_i32_1d *futhark_new_raw_i32_1d(struct futhark_context *ctx,+                                                cl_mem data,+                                                int offset,+                                                int dim0);++This function *does* copy the provided memory into fresh internally+allocated memory.  The array is assumed to be stored in row-major form+``offset`` bytes into the memory region.++See also :ref:`futhark-opencl(1)`.++Generating Python+^^^^^^^^^^^^^^^^^++The ``futhark py`` and ``futhark pyopencl`` compilers both support+generating reusable Python code, although the latter of these+generates code of sufficient performance to be worthwhile.  The+following mentions options and parameters only available for+``futhark pyopencl``.  You will need at least PyOpenCL version 2015.2.++We can use ``futhark pyopencl`` to translate the program+``futlib.fut`` into a Python module ``futlib.py`` with the following+command::++  $ futhark pyopencl --library futlib.fut++This will create a file ``futlib.py``, which contains Python code that+defines a class named ``futlib``.  This class defines one method for+each entry point function (see :ref:`entry-points`) in the Futhark+program.  The methods take one parameter for each parameter in the+corresponding entry point, and return a tuple containing a value for+every value returned by the entry point.  For entry points returning a+single (non-tuple) value, just that value is returned (that is,+single-element tuples are not returned).++After the class has been instantiated, these methods can be invoked to+run the corresponding Futhark function.  The constructor for the class+takes various keyword parameters:++  ``interactive=BOOL``++    If ``True`` (the default is ``False``), show a menu of available+    OpenCL platforms and devices, and use the one chosen by the user.++  ``platform_pref=STR``++    Use the first platform that contains the given string.  Similar to+    the ``-p`` option for executables.++  ``device_pref=STR``++    Use the first device that contains the given string.  Similar to+    the ``-d`` option for executables.++Futhark arrays are mapped to either the Numpy ``ndarray`` type or the+`pyopencl.array <https://documen.tician.de/pyopencl/array.html>`_+type.  Scalars are mapped to Numpy scalar types.
+ docs/versus-other-languages.rst view
@@ -0,0 +1,195 @@+.. _versus-other-languages:++Futhark Compared to Other Functional Languages+==============================================++This guide is intended for programmers who are familiar with other functional+languages and want to start working with Futhark.++Futhark is a simple language with a complex compiler.+Functional programming is fundamentally well suited to+data-parallelism, so Futhark's syntax and underlying concepts are taken directly+from established functional languages; mostly from Haskell and the+members of the ML family.  While Futhark does add a few small+conveniences (built-in array types) and one complicated and unusual+feature (in-place updates via uniqueness types, see+:ref:`in-place-updates`), a programmer familiar with a common+functional language should be able to understand the meaning of a+Futhark program, and quickly begin writing their own programs.  To+speed up this process, we describe here some of the various+quirks and unexpected limitations imposed by Futhark. We also+recommended reading some of the `example programs`_ along with this guide.+The guide does *not* cover all Futhark features worth knowing, so do also+skim :ref:`language-reference`.++.. _`example programs`: https://github.com/diku-dk/futhark/tree/master/examples++Basic Syntax+------------++Futhark uses a keyword-based structure, with optional indentation+*solely* for human readability.  This aspect differs from Haskell and F#.++Names are lexically divided into *identifiers* and *symbols*:++* *Identifiers* begin with a letter or underscore and contain letters,+  numbers, underscores, and apostrophes.++* *Symbols* contain the characters found in the default operators+  (``+-*/%=!><|&^``)++All function and variable names must be identifiers, and all infix+operators are symbols.  An identifier can be used as an infix operator+by enclosing it in backticks, as in Haskell.++Identifiers are case-sensitive, and there is no restriction on the+case of the first letter (unlike Haskell and OCaml, but like Standard+ML).++User-defined operators are possible, but the fixity of the operator+depends on its name.  Specifically, the fixity of a user-defined+operator *op* is equal to the fixity of the built-in operator that is+the longest prefix of *op*.  For example, ``<<=`` would have the+same fixity as ``<<``, and ``=<<`` the same as ``=``.  This rule is the+same as the rule found in OCaml and F#.++Top-level functions and values are defined with ``let``, as in OCaml+and F#.++Evaluation+----------++Futhark is a completely pure language, with no cheating through monads+or anything of the sort.++Evaluation is *eager* or *call-by-value*, like most non-Haskell+languages.  However, there is no defined evaluation order.+Furthermore, the Futhark compiler is permitted to turn non-terminating+programs into terminating programs, for example by removing dead code+that might cause an error.  Moreover, there is no way to+handle errors within a Futhark program (no exceptions or similar);+although errors are gracefully reported to whatever invokes the+Futhark program.++The evaluation semantics are entirely sequential, with parallelism+being solely an operational detail.  Hence, race conditions are+impossible. The Futhark compiler does not automatically go+looking for parallelism.  Only certain special constructs and built-in+library functions (in particular ``map``, ``reduce``, ``scan``, and+``filter``) may be executed in parallel.++Currying and partial application work as usual (although functions+are not fully first class; see `Types`_).  Some Futhark language+constructs look like functions, but are not.  This means they cannot+be partially applied.  These include ``unsafe`` and ``assert``.++Lambda terms are written as ``\x -> x + 2``, as in Haskell.++A Futhark program is read top-down, and all functions must be declared+in the order they are used, like Standard ML.  Unlike just+about all functional languages, recursive functions are *not*+supported.  Most of the time, you will use bulk array operations+instead, but there is also a dedicated ``loop`` language construct,+which is essentially syntactic sugar for tail recursive functions.++Types+-----++Futhark supports a range of integer types, floating point types, and+booleans (see :ref:`primitives`).  A numeric literal can be suffixed+with its desired type, such as ``1i8`` for an eight-bit signed+integer.  Un-adorned numerals have their type inferred based on use.+This only works for built-in numeric types.++Arrays are a built-in type.  The type of an array containing elements+of type ``t`` is written ``[]t`` (not ``[t]`` as in Haskell), and we+may optionally annotate it with a size as ``[n]t`` (see `Shape+Declarations`).  Array values are written as ``[1,2,3]``.  Array+indexing is written ``a[i]`` with *no* space allowed between the array+name and the brace.  Indexing of multi-dimensional arrays is written+``a[i,j]``.  Arrays are 0-indexed.++All types can be combined in tuples as usual, as well as in+*structurally typed records*, as in Standard ML.  Non-recursive sum+types are supported, and are also structurally typed.  Abstract types+are possible via the module system; see :ref:`module-system`.++If a variable ``foo`` is a record of type ``{a: i32, b: bool}``, then+we access field ``a`` with dot notation: ``foo.a``.  Tuples are a+special case of records, where all the fields have a 0-indexed numeric+label.  For example, ``(i32, bool)`` is the same as ``{0: i32, 1:+bool}``, and can be indexed as ``foo.1``.++Sum types are defined as constructors separated by a vertical bar+(``|``).  Constructor names always start with a ``#``.  For example,+``#red | #blue i32`` is a sum type with the constructors ``#red`` and+``#blue``, where the latter has an ``i32`` as payload.  The terms+``#red`` and ``#blue 2`` produce values of this type.  Constructor+applications must always be fully saturated.  Due to the structural+typing, type annotations are usually necessary to resolve ambiguities.+For example, the term ``#blue 2`` can produce a value of *any type*+that has an appropriate constructor.++Function types are supported with the usual ``a -> b``, and functions can be+passed as arguments to other functions.  However, there are some+restrictions:++* A function cannot be put in an array (but a record or tuple is+  fine).++* A function cannot be returned from a branch.++* A function cannot be used as a ``loop`` parameter.++Function types interact with type parameters in a subtle way::++  let id 't (x: t) = x++This declaration defines a function ``id`` that has a type parameter+``t``.  Here, ``t`` is an *unlifted* type parameter, which is+guaranteed never to be a function type, and so in the body of the+function we could choose to put parameter values of type ``t`` in an+array.  However, it means that this identity function cannot be called+on a functional value.  Instead, we probably want a *lifted* type+parameter::++  let id '^t (x: t) = x++Such *lifted* type parameters are not restricted from being+instantiated with function types.  On the other hand, in the function+definition they are subject to the same restrictions as functional+types.++Futhark supports Hindley-Milner type inference (with some+restrictions), so we could also just write it as::++  let id x = x++Type abbreviations are possible::++  type foo = (i32, i32)++Type parameters are supported as well::++  type pair 'a 'b = (a, b)++As with everything else, they are structurally typed, so the types+``pair i32 bool`` and ``(i32, bool)`` are entirely interchangeable.+Most unusually, this is also the case for sum types.  The following+two types are entirely interchangeable::++  type maybe 'a = #just a | #nothing++  type option 'a = #nothing | #just a++Only for abstract types, where the definition has been hidden via the+module system, do type names have any significance.++Size parameters can also be passed::++  type vector [n] t = [n]t+  type i32matrix [n][m] = [n] (vector [m] i32)++Note that for an actual array type, the dimensions come *before* the+element type, but with a type abbreviation, a size is just another+parameter.  This easily becomes hard to read if you are not careful.
futhark.cabal view
@@ -1,13 +1,7 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.31.2.------ see: https://github.com/sol/hpack------ hash: f4cfd9b833eff0672980c67287441d068079b0a227279aa3a06a58262a3833c6+cabal-version: 2.4  name:           futhark-version:        0.14.1+version:        0.15.1 synopsis:       An optimising compiler for a functional, array-oriented language. description:    Futhark is a small programming language designed to be compiled to                 efficient parallel code. It is a statically typed, data-parallel,@@ -25,55 +19,16 @@ license-file:   LICENSE build-type:     Simple extra-source-files:-    rts/python/memory.py-    rts/python/opencl.py-    rts/python/panic.py-    rts/python/scalar.py-    rts/python/tuning.py-    rts/python/values.py-    rts/c/cuda.h-    rts/c/free_list.h-    rts/c/lock.h-    rts/c/opencl.h-    rts/c/panic.h-    rts/c/timing.h-    rts/c/tuning.h-    rts/c/values.h-    rts/csharp/exceptions.cs-    rts/csharp/functions.cs-    rts/csharp/memory.cs-    rts/csharp/memory_opencl.cs-    rts/csharp/opencl.cs-    rts/csharp/panic.cs-    rts/csharp/reader.cs-    rts/csharp/scalar.cs-    rts/futhark-doc/style.css-    futlib/array.fut-    futlib/functional.fut-    futlib/math.fut-    futlib/prelude.fut-    futlib/soacs.fut-    futlib/zip.fut+    rts/c/*.h+    rts/csharp/*.cs+    rts/futhark-doc/*.css+    rts/python/*.py+    prelude/*.fut+-- Just enough of the docs to build the manpages.+    docs/**/*.rst     docs/Makefile     docs/conf.py-    docs/index.rst-    docs/man/futhark-autotune.rst-    docs/man/futhark-bench.rst-    docs/man/futhark-c.rst-    docs/man/futhark-csharp.rst-    docs/man/futhark-csopencl.rst-    docs/man/futhark-cuda.rst-    docs/man/futhark-dataset.rst-    docs/man/futhark-doc.rst-    docs/man/futhark-opencl.rst-    docs/man/futhark-pkg.rst-    docs/man/futhark-pyopencl.rst-    docs/man/futhark-python.rst-    docs/man/futhark-repl.rst-    docs/man/futhark-run.rst-    docs/man/futhark-test.rst-    docs/man/futhark.rst-    package.yaml+    docs/requirements.txt  source-repository head   type: git@@ -91,6 +46,7 @@       Futhark.Analysis.Metrics       Futhark.Analysis.PrimExp       Futhark.Analysis.PrimExp.Convert+      Futhark.Analysis.PrimExp.Generalize       Futhark.Analysis.PrimExp.Simplify       Futhark.Analysis.Range       Futhark.Analysis.Rephrase@@ -104,6 +60,7 @@       Futhark.CLI.Autotune       Futhark.CLI.Bench       Futhark.CLI.C+      Futhark.CLI.Check       Futhark.CLI.CSharp       Futhark.CLI.CSOpenCL       Futhark.CLI.CUDA@@ -265,7 +222,7 @@       Language.Futhark       Language.Futhark.Attributes       Language.Futhark.Core-      Language.Futhark.Futlib+      Language.Futhark.Prelude       Language.Futhark.Interpreter       Language.Futhark.Parser       Language.Futhark.Pretty@@ -284,9 +241,14 @@       Language.Futhark.Parser.Parser       Language.Futhark.Parser.Lexer       Paths_futhark+  autogen-modules:+      Paths_futhark   hs-source-dirs:       src   ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists+  build-tool-depends:+      alex:alex+    , happy:happy   build-depends:       aeson >=1.0.0.0     , ansi-terminal >=0.6.3.1@@ -334,9 +296,6 @@     , versions >=3.3.1     , zip-archive >=0.3.1.1     , zlib >=0.6.1.2-  build-tools:-      alex-    , happy   default-language: Haskell2010  executable futhark
− futlib/array.fut 
@@ -1,144 +0,0 @@--- | Utility functions for arrays.--import "math"-import "soacs"-import "functional"-open import "zip" -- Rexport.---- | The size of the outer dimension of an array.-let length [n] 't (_: [n]t) = n---- | Is the array empty?-let null [n] 't (_: [n]t) = n == 0---- | The first element of the array.-let head [n] 't (x: [n]t) = x[0]---- | The last element of the array.-let last [n] 't (x: [n]t) = x[n-1]---- | Everything but the first element of the array.-let tail [n] 't (x: [n]t) = x[1:]---- | Everything but the last element of the array.-let init [n] 't (x: [n]t) = x[0:n-1]---- | Take some number of elements from the head of the array.-let take [n] 't (i: i32) (x: [n]t): [i]t = x[0:i]---- | Remove some number of elements from the head of the array.-let drop [n] 't (i: i32) (x: [n]t) = x[i:]---- | Split an array at a given position.-let split 't (n: i32) (xs: []t): ([n]t, []t) =-  (xs[:n], xs[n:])---- | Split an array at two given positions.-let split2 't (i: i32) (j: i32) (xs: []t): ([i]t, []t, []t) =-  (xs[:i], xs[i:j], xs[j:])---- | Return the elements of the array in reverse order.-let reverse [n] 't (x: [n]t): [n]t = x[::-1]---- | Concatenate two arrays.  Warning: never try to perform a reduction--- with this operator; it will not work.-let (++) 't (xs: []t) (ys: []t): *[]t = intrinsics.concat (xs, ys)---- | An old-fashioned way of saying `++`.-let concat 't (xs: []t) (ys: []t): *[]t = xs ++ ys---- | Rotate an array some number of elements to the left.  A negative--- rotation amount is also supported.------ For example, if `b==rotate r a`, then `b[x+r] = a[x]`.-let rotate 't (r: i32) (xs: []t) = intrinsics.rotate (r, xs)---- | Replace an element of the array with a new value.-let update [n] 't (xs: *[n]t) (i: i32) (x: t): *[n]t = xs with [i] = x---- | Construct an array of consecutive integers of the given length,--- starting at 0.-let iota (n: i32): *[n]i32 =-  i32.iota n---- | Construct an array of the given length containing the given--- value.-let replicate 't (n: i32) (x: t): *[n]t =-  i32.replicate n x---- | Copy a value.  The result will not alias anything.-let copy 't (a: t): *t =-  ([a])[0]---- | Combines the outer two dimensions of an array.-let flatten [n][m] 't (xs: [n][m]t): []t =-  intrinsics.flatten xs---- | Combines the outer three dimensions of an array.-let flatten_3d [n][m][l] 't (xs: [n][m][l]t): []t =-  flatten (flatten xs)---- | Combines the outer four dimensions of an array.-let flatten_4d [n][m][l][k] 't (xs: [n][m][l][k]t): []t =-  flatten (flatten_3d xs)---- | Splits the outer dimension of an array in two.-let unflatten 't (n: i32) (m: i32) (xs: []t): [n][m]t =-  intrinsics.unflatten (n, m, xs)---- | Splits the outer dimension of an array in three.-let unflatten_3d 't (n: i32) (m: i32) (l: i32) (xs: []t): [n][m][l]t =-  unflatten n m (unflatten (n*m) l xs)---- | Splits the outer dimension of an array in four.-let unflatten_4d 't (n: i32) (m: i32) (l: i32) (k: i32) (xs: []t): [n][m][l][k]t =-  unflatten n m (unflatten_3d (n*m) l k xs)--let intersperse [n] 't (x: t) (xs: [n]t): *[]t =-  map (\i -> if i % 2 == 1 && i != 2*n then x-             else unsafe xs[i/2])-      (iota (i32.max (2*n-1) 0))--let intercalate [n] [m] 't (x: [m]t) (xs: [n][m]t): []t =-  unsafe flatten (intersperse x xs)--let transpose [n] [m] 't (a: [n][m]t): [m][n]t =-  intrinsics.transpose a--let steps (start: i32) (num_steps: i32) (step: i32): [num_steps]i32 =-  map (start+) (map (step*) (iota num_steps))--let range (start: i32) (end: i32) (step: i32): []i32 =-  let w = (end-start)/step-  in steps start w step---- | True if all of the input elements are true.  Produces true on an--- empty array.-let and: []bool -> bool = all id---- | True if any of the input elements are true.  Produces false on an--- empty array.-let or: []bool -> bool = any id--let pick [n] 't (flags: [n]bool) (xs: [n]t) (ys: [n]t): *[n]t =-  map3 (\flag x y -> if flag then x else y) flags xs ys---- | Perform a *sequential* left-fold of an array.-let foldl 'a 'b (f: a -> b -> a) (acc: a) (bs: []b): a =-  loop acc for b in bs do f acc b---- | Perform a *sequential* right-fold of an array.-let foldr 'a 'b (f: b -> a -> a) (acc: a) (bs: []b): a =-  foldl (flip f) acc (reverse bs)---- | Create a value for each point in a one-dimensional index space.-let tabulate 'a (n: i32) (f: i32 -> a): *[n]a =-  map1 f (iota n)---- | Create a value for each point in a two-dimensional index space.-let tabulate_2d 'a (n: i32) (m: i32) (f: i32 -> i32 -> a): *[n][m]a =-  map1 (f >-> tabulate m) (iota n)---- | Create a value for each point in a three-dimensional index space.-let tabulate_3d 'a (n: i32) (m: i32) (o: i32) (f: i32 -> i32 -> i32 -> a): *[n][m][o]a =-  map1 (f >-> tabulate_2d m o) (iota n)
− futlib/functional.fut 
@@ -1,57 +0,0 @@--- | Simple functional combinators.---- | Left-to-right application.  Particularly useful for describing--- computation pipelines:------ ```--- x |> f |> g |> h--- ```-let (|>) '^a '^b (x: a) (f: a -> b): b = f x---- | Right to left application.-let (<|) '^a '^b (f: a -> b) (x: a) = f x---- | Function composition, with values flowing from left to right.-let (>->) '^a '^b '^c (f: a -> b) (g: b -> c) (x: a): c = g (f x)---- | Function composition, with values flowing from right to left.--- This is the same as the `∘` operator known from mathematics.-let (<-<) '^a '^b '^c (g: b -> c) (f: a -> b) (x: a): c = g (f x)---- | Flip the arguments passed to a function.------ ```--- f x y == flip f y x--- ```-let flip '^a '^b '^c (f: a -> b -> c) (b: b) (a: a): c =-  f a b---- | Transform a function taking a pair into a function taking two--- arguments.-let curry '^a '^b '^c (f: (a, b) -> c) (a: a) (b: b): c =-  f (a, b)---- | Transform a function taking two arguments in a function taking a--- pair.-let uncurry '^a '^b '^c (f: a -> b -> c) (a: a, b: b): c =-  f a b---- | The constant function.-let const '^a '^b (x: a) (_: b): a = x---- | The identity function.-let id '^a (x: a) = x---- | Apply a function some number of times.-let iterate 'a (n: i32) (f: a -> a) (x: a) =-  loop x for _i < n do f x---- | Keep applying `f` until `p` returns true for the input value.--- May apply zero times.  *Note*: may not terminate.-let iterate_until 'a (p: a -> bool) (f: a -> a) (x: a) =-  loop x while ! (p x) do f x---- | Keep applying `f` while `p` returns true for the input value.--- May apply zero times.  *Note*: may not terminate.-let iterate_while 'a (p: a -> bool) (f: a -> a) (x: a) =-  loop x while p x do f x
− futlib/math.fut 
@@ -1,992 +0,0 @@--- | Basic mathematical modules and functions.--import "soacs"--local let const 'a 'b (x: a) (_: b): a = x---- | Describes types of values that can be created from the primitive--- numeric types (and bool).-module type from_prim = {-  type t--  val i8: i8 -> t-  val i16: i16 -> t-  val i32: i32 -> t-  val i64: i64 -> t--  val u8: u8 -> t-  val u16: u16 -> t-  val u32: u32 -> t-  val u64: u64 -> t--  val f32: f32 -> t-  val f64: f64 -> t--  val bool: bool -> t-}---- | A basic numeric module type that can be implemented for both--- integers and rational numbers.-module type numeric = {-  include from_prim--  val +: t -> t -> t-  val -: t -> t -> t-  val *: t -> t -> t-  val /: t -> t -> t-  val %: t -> t -> t-  val **: t -> t -> t--  val to_i64: t -> i64--  val ==: t -> t -> bool-  val <: t -> t -> bool-  val >: t -> t -> bool-  val <=: t -> t -> bool-  val >=: t -> t -> bool-  val !=: t -> t -> bool--  val negate: t-> t-  val max: t -> t -> t-  val min: t -> t -> t--  val abs: t -> t--  val sgn: t -> t--  -- | The highest representable number.-  val highest: t--  -- | The lowest representable number.-  val lowest: t--  -- | Returns zero on empty input.-  val sum [n]: [n]t -> t--  -- | Returns one on empty input.-  val product [n]: [n]t -> t--  -- | Returns `lowest` on empty input.-  val maximum [n]: [n]t -> t-  -- | Returns `highest` on empty input.-  val minimum [n]: [n]t -> t-}---- | An extension of `numeric`@mtype that provides facilities that are--- only meaningful for integral types.-module type integral = {-  include numeric--  val //: t -> t -> t-  val %%: t -> t -> t--  val &: t -> t -> t-  val |: t -> t -> t-  val ^: t -> t -> t-  val !: t -> t--  val <<: t -> t -> t-  val >>: t -> t -> t-  val >>>: t -> t -> t--  val num_bits: i32-  val get_bit: i32 -> t -> i32-  val set_bit: i32 -> t -> i32 -> t--  -- | Count number of one bits.-  val popc: t -> i32--  -- | Count number of zero bits preceding the most significant set-  -- bit.-  val clz: t -> i32-}---- | An extension of `size`@mtype that further includes facilities for--- constructing arrays where the size is provided as a value of the--- given integral type.-module type size = {-  include integral--  val iota: t -> *[]t-  val replicate 'v: t -> v -> *[]v-}---- | Numbers that model real numbers to some degree.-module type real = {-  include numeric--  val from_fraction: i32 -> i32 -> t-  val to_i32: t -> i32-  val to_i64: t -> i64-  val to_f64: t -> f64--  val sqrt: t -> t-  val exp: t -> t-  val cos: t -> t-  val sin: t -> t-  val tan: t -> t-  val asin: t -> t-  val acos: t -> t-  val atan: t -> t-  val atan2: t -> t -> t-  val gamma: t -> t-  val lgamma: t -> t-  -- | Linear interpolation.  The third argument must be in the range-  -- `[0,1]` or the results are unspecified.-  val lerp: t -> t -> t -> t--  -- | Natural logarithm.-  val log: t -> t-  -- | Base-2 logarithm.-  val log2: t -> t-  -- | Base-10 logarithm.-  val log10: t -> t--  val ceil : t -> t-  val floor : t -> t-  val trunc : t -> t--  -- | Round to the nearest integer, with alfway cases rounded to the-  -- nearest even integer.  Note that this differs from `round()` in-  -- C, but matches more modern languages.-  val round : t -> t--  val isinf: t -> bool-  val isnan: t -> bool--  val inf: t-  val nan: t--  val pi: t-  val e: t-}---- | An extension of `real`@mtype that further gives access to the--- bitwise representation of the underlying number.  It is presumed--- that this will be some form of IEEE float.-module type float = {-  include real--  -- | An unsigned integer type containing the same number of bits as-  -- 't'.-  type int_t--  val from_bits: int_t -> t-  val to_bits: t -> int_t--  val num_bits: i32-  val get_bit: i32 -> t -> i32-  val set_bit: i32 -> t -> i32 -> t-}---- | Boolean numbers.  When converting from a number to `bool`, 0 is--- considered `false` and any other value is `true`.-module bool: from_prim with t = bool = {-  type t = bool--  let i8  = intrinsics.itob_i8_bool-  let i16 = intrinsics.itob_i16_bool-  let i32 = intrinsics.itob_i32_bool-  let i64 = intrinsics.itob_i64_bool--  let u8  (x: u8)  = intrinsics.itob_i8_bool (intrinsics.sign_i8 x)-  let u16 (x: u16) = intrinsics.itob_i16_bool (intrinsics.sign_i16 x)-  let u32 (x: u32) = intrinsics.itob_i32_bool (intrinsics.sign_i32 x)-  let u64 (x: u64) = intrinsics.itob_i64_bool (intrinsics.sign_i64 x)--  let f32 (x: f32) = x != 0f32-  let f64 (x: f64) = x != 0f64--  let bool (x: bool) = x-}--module i8: (size with t = i8) = {-  type t = i8--  let (x: i8) + (y: i8) = intrinsics.add8 (x, y)-  let (x: i8) - (y: i8) = intrinsics.sub8 (x, y)-  let (x: i8) * (y: i8) = intrinsics.mul8 (x, y)-  let (x: i8) / (y: i8) = intrinsics.sdiv8 (x, y)-  let (x: i8) ** (y: i8) = intrinsics.pow8 (x, y)-  let (x: i8) % (y: i8) = intrinsics.smod8 (x, y)-  let (x: i8) // (y: i8) = intrinsics.squot8 (x, y)-  let (x: i8) %% (y: i8) = intrinsics.srem8 (x, y)--  let (x: i8) & (y: i8) = intrinsics.and8 (x, y)-  let (x: i8) | (y: i8) = intrinsics.or8 (x, y)-  let (x: i8) ^ (y: i8) = intrinsics.xor8 (x, y)-  let ! (x: i8) = intrinsics.complement8 x--  let (x: i8) << (y: i8) = intrinsics.shl8 (x, y)-  let (x: i8) >> (y: i8) = intrinsics.ashr8 (x, y)-  let (x: i8) >>> (y: i8) = intrinsics.lshr8 (x, y)--  let i8  (x: i8)  = intrinsics.sext_i8_i8 x-  let i16 (x: i16) = intrinsics.sext_i16_i8 x-  let i32 (x: i32) = intrinsics.sext_i32_i8 x-  let i64 (x: i64) = intrinsics.sext_i64_i8 x--  let u8  (x: u8)  = intrinsics.zext_i8_i8 (intrinsics.sign_i8 x)-  let u16 (x: u16) = intrinsics.zext_i16_i8 (intrinsics.sign_i16 x)-  let u32 (x: u32) = intrinsics.zext_i32_i8 (intrinsics.sign_i32 x)-  let u64 (x: u64) = intrinsics.zext_i64_i8 (intrinsics.sign_i64 x)--  let f32 (x: f32) = intrinsics.fptosi_f32_i8 x-  let f64 (x: f64) = intrinsics.fptosi_f64_i8 x--  let bool = intrinsics.btoi_bool_i8--  let to_i32(x: i8) = intrinsics.sext_i8_i32 x-  let to_i64(x: i8) = intrinsics.sext_i8_i64 x--  let (x: i8) == (y: i8) = intrinsics.eq_i8 (x, y)-  let (x: i8) < (y: i8) = intrinsics.slt8 (x, y)-  let (x: i8) > (y: i8) = intrinsics.slt8 (y, x)-  let (x: i8) <= (y: i8) = intrinsics.sle8 (x, y)-  let (x: i8) >= (y: i8) = intrinsics.sle8 (y, x)-  let (x: i8) != (y: i8) = intrinsics.! (x == y)--  let sgn (x: i8) = intrinsics.ssignum8 x-  let abs (x: i8) = intrinsics.abs8 x--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.smax8 (x, y)-  let min (x: t) (y: t) = intrinsics.smin8 (x, y)--  let highest = 127i8-  let lowest = highest + 1i8--  let num_bits = 8-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc = intrinsics.popc8-  let clz = intrinsics.clz8--  let iota (n: i8) = 0i8..1i8..<n-  let replicate 'v (n: i8) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module i16: (size with t = i16) = {-  type t = i16--  let (x: i16) + (y: i16) = intrinsics.add16 (x, y)-  let (x: i16) - (y: i16) = intrinsics.sub16 (x, y)-  let (x: i16) * (y: i16) = intrinsics.mul16 (x, y)-  let (x: i16) / (y: i16) = intrinsics.sdiv16 (x, y)-  let (x: i16) ** (y: i16) = intrinsics.pow16 (x, y)-  let (x: i16) % (y: i16) = intrinsics.smod16 (x, y)-  let (x: i16) // (y: i16) = intrinsics.squot16 (x, y)-  let (x: i16) %% (y: i16) = intrinsics.srem16 (x, y)--  let (x: i16) & (y: i16) = intrinsics.and16 (x, y)-  let (x: i16) | (y: i16) = intrinsics.or16 (x, y)-  let (x: i16) ^ (y: i16) = intrinsics.xor16 (x, y)-  let ! (x: i16) = intrinsics.complement16 x--  let (x: i16) << (y: i16) = intrinsics.shl16 (x, y)-  let (x: i16) >> (y: i16) = intrinsics.ashr16 (x, y)-  let (x: i16) >>> (y: i16) = intrinsics.lshr16 (x, y)--  let i8  (x: i8)  = intrinsics.sext_i8_i16 x-  let i16 (x: i16) = intrinsics.sext_i16_i16 x-  let i32 (x: i32) = intrinsics.sext_i32_i16 x-  let i64 (x: i64) = intrinsics.sext_i64_i16 x--  let u8  (x: u8)  = intrinsics.zext_i8_i16 (intrinsics.sign_i8 x)-  let u16 (x: u16) = intrinsics.zext_i16_i16 (intrinsics.sign_i16 x)-  let u32 (x: u32) = intrinsics.zext_i32_i16 (intrinsics.sign_i32 x)-  let u64 (x: u64) = intrinsics.zext_i64_i16 (intrinsics.sign_i64 x)--  let f32 (x: f32) = intrinsics.fptosi_f32_i16 x-  let f64 (x: f64) = intrinsics.fptosi_f64_i16 x--  let bool = intrinsics.btoi_bool_i16--  let to_i32(x: i16) = intrinsics.sext_i16_i32 x-  let to_i64(x: i16) = intrinsics.sext_i16_i64 x--  let (x: i16) == (y: i16) = intrinsics.eq_i16 (x, y)-  let (x: i16) < (y: i16) = intrinsics.slt16 (x, y)-  let (x: i16) > (y: i16) = intrinsics.slt16 (y, x)-  let (x: i16) <= (y: i16) = intrinsics.sle16 (x, y)-  let (x: i16) >= (y: i16) = intrinsics.sle16 (y, x)-  let (x: i16) != (y: i16) = intrinsics.! (x == y)--  let sgn (x: i16) = intrinsics.ssignum16 x-  let abs (x: i16) = intrinsics.abs16 x--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.smax16 (x, y)-  let min (x: t) (y: t) = intrinsics.smin16 (x, y)--  let highest = 32767i16-  let lowest = highest + 1i16--  let num_bits = 16-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc = intrinsics.popc16-  let clz = intrinsics.clz16--  let iota (n: i16) = 0i16..1i16..<n-  let replicate 'v (n: i16) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module i32: (size with t = i32) = {-  type t = i32--  let sign (x: u32) = intrinsics.sign_i32 x-  let unsign (x: i32) = intrinsics.unsign_i32 x--  let (x: i32) + (y: i32) = intrinsics.add32 (x, y)-  let (x: i32) - (y: i32) = intrinsics.sub32 (x, y)-  let (x: i32) * (y: i32) = intrinsics.mul32 (x, y)-  let (x: i32) / (y: i32) = intrinsics.sdiv32 (x, y)-  let (x: i32) ** (y: i32) = intrinsics.pow32 (x, y)-  let (x: i32) % (y: i32) = intrinsics.smod32 (x, y)-  let (x: i32) // (y: i32) = intrinsics.squot32 (x, y)-  let (x: i32) %% (y: i32) = intrinsics.srem32 (x, y)--  let (x: i32) & (y: i32) = intrinsics.and32 (x, y)-  let (x: i32) | (y: i32) = intrinsics.or32 (x, y)-  let (x: i32) ^ (y: i32) = intrinsics.xor32 (x, y)-  let ! (x: i32) = intrinsics.complement32 x--  let (x: i32) << (y: i32) = intrinsics.shl32 (x, y)-  let (x: i32) >> (y: i32) = intrinsics.ashr32 (x, y)-  let (x: i32) >>> (y: i32) = intrinsics.lshr32 (x, y)--  let i8  (x: i8)  = intrinsics.sext_i8_i32 x-  let i16 (x: i16) = intrinsics.sext_i16_i32 x-  let i32 (x: i32) = intrinsics.sext_i32_i32 x-  let i64 (x: i64) = intrinsics.sext_i64_i32 x--  let u8  (x: u8)  = intrinsics.zext_i8_i32 (intrinsics.sign_i8 x)-  let u16 (x: u16) = intrinsics.zext_i16_i32 (intrinsics.sign_i16 x)-  let u32 (x: u32) = intrinsics.zext_i32_i32 (intrinsics.sign_i32 x)-  let u64 (x: u64) = intrinsics.zext_i64_i32 (intrinsics.sign_i64 x)--  let f32 (x: f32) = intrinsics.fptosi_f32_i32 x-  let f64 (x: f64) = intrinsics.fptosi_f64_i32 x--  let bool = intrinsics.btoi_bool_i32--  let to_i32(x: i32) = intrinsics.sext_i32_i32 x-  let to_i64(x: i32) = intrinsics.sext_i32_i64 x--  let (x: i32) == (y: i32) = intrinsics.eq_i32 (x, y)-  let (x: i32) < (y: i32) = intrinsics.slt32 (x, y)-  let (x: i32) > (y: i32) = intrinsics.slt32 (y, x)-  let (x: i32) <= (y: i32) = intrinsics.sle32 (x, y)-  let (x: i32) >= (y: i32) = intrinsics.sle32 (y, x)-  let (x: i32) != (y: i32) = intrinsics.! (x == y)--  let sgn (x: i32) = intrinsics.ssignum32 x-  let abs (x: i32) = intrinsics.abs32 x--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.smax32 (x, y)-  let min (x: t) (y: t) = intrinsics.smin32 (x, y)--  let highest = 2147483647-  let lowest = highest + 1--  let num_bits = 32-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc = intrinsics.popc32-  let clz = intrinsics.clz32--  let iota (n: i32) = 0..1..<n-  let replicate 'v (n: i32) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module i64: (size with t = i64) = {-  type t = i64--  let sign (x: u64) = intrinsics.sign_i64 x-  let unsign (x: i64) = intrinsics.unsign_i64 x--  let (x: i64) + (y: i64) = intrinsics.add64 (x, y)-  let (x: i64) - (y: i64) = intrinsics.sub64 (x, y)-  let (x: i64) * (y: i64) = intrinsics.mul64 (x, y)-  let (x: i64) / (y: i64) = intrinsics.sdiv64 (x, y)-  let (x: i64) ** (y: i64) = intrinsics.pow64 (x, y)-  let (x: i64) % (y: i64) = intrinsics.smod64 (x, y)-  let (x: i64) // (y: i64) = intrinsics.squot64 (x, y)-  let (x: i64) %% (y: i64) = intrinsics.srem64 (x, y)--  let (x: i64) & (y: i64) = intrinsics.and64 (x, y)-  let (x: i64) | (y: i64) = intrinsics.or64 (x, y)-  let (x: i64) ^ (y: i64) = intrinsics.xor64 (x, y)-  let ! (x: i64) = intrinsics.complement64 x--  let (x: i64) << (y: i64) = intrinsics.shl64 (x, y)-  let (x: i64) >> (y: i64) = intrinsics.ashr64 (x, y)-  let (x: i64) >>> (y: i64) = intrinsics.lshr64 (x, y)--  let i8  (x: i8)  = intrinsics.sext_i8_i64 x-  let i16 (x: i16) = intrinsics.sext_i16_i64 x-  let i32 (x: i32) = intrinsics.sext_i32_i64 x-  let i64 (x: i64) = intrinsics.sext_i64_i64 x--  let u8  (x: u8)  = intrinsics.zext_i8_i64 (intrinsics.sign_i8 x)-  let u16 (x: u16) = intrinsics.zext_i16_i64 (intrinsics.sign_i16 x)-  let u32 (x: u32) = intrinsics.zext_i32_i64 (intrinsics.sign_i32 x)-  let u64 (x: u64) = intrinsics.zext_i64_i64 (intrinsics.sign_i64 x)--  let f32 (x: f32) = intrinsics.fptosi_f32_i64 x-  let f64 (x: f64) = intrinsics.fptosi_f64_i64 x--  let bool = intrinsics.btoi_bool_i64--  let to_i32(x: i64) = intrinsics.sext_i64_i32 x-  let to_i64(x: i64) = intrinsics.sext_i64_i64 x--  let (x: i64) == (y: i64) = intrinsics.eq_i64 (x, y)-  let (x: i64) < (y: i64) = intrinsics.slt64 (x, y)-  let (x: i64) > (y: i64) = intrinsics.slt64 (y, x)-  let (x: i64) <= (y: i64) = intrinsics.sle64 (x, y)-  let (x: i64) >= (y: i64) = intrinsics.sle64 (y, x)-  let (x: i64) != (y: i64) = intrinsics.! (x == y)--  let sgn (x: i64) = intrinsics.ssignum64 x-  let abs (x: i64) = intrinsics.abs64 x--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.smax64 (x, y)-  let min (x: t) (y: t) = intrinsics.smin64 (x, y)--  let highest = 9223372036854775807i64-  let lowest = highest + 1i64--  let num_bits = 64-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | intrinsics.zext_i32_i64 (b intrinsics.<< bit))-  let popc = intrinsics.popc64-  let clz = intrinsics.clz64--  let iota (n: i64) = 0i64..1i64..<n-  let replicate 'v (n: i64) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module u8: (size with t = u8) = {-  type t = u8--  let sign (x: u8) = intrinsics.sign_i8 x-  let unsign (x: i8) = intrinsics.unsign_i8 x--  let (x: u8) + (y: u8) = unsign (intrinsics.add8 (sign x, sign y))-  let (x: u8) - (y: u8) = unsign (intrinsics.sub8 (sign x, sign y))-  let (x: u8) * (y: u8) = unsign (intrinsics.mul8 (sign x, sign y))-  let (x: u8) / (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))-  let (x: u8) ** (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))-  let (x: u8) % (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))-  let (x: u8) // (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))-  let (x: u8) %% (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))--  let (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x, sign y))-  let (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x, sign y))-  let (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x, sign y))-  let ! (x: u8) = unsign (intrinsics.complement8 (sign x))--  let (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x, sign y))-  let (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y))-  let (x: u8) >>> (y: u8) = unsign (intrinsics.lshr8 (sign x, sign y))--  let u8  (x: u8)  = unsign (i8.u8 x)-  let u16 (x: u16) = unsign (i8.u16 x)-  let u32 (x: u32) = unsign (i8.u32 x)-  let u64 (x: u64) = unsign (i8.u64 x)--  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i8 x)-  let i16 (x: i16) = unsign (intrinsics.zext_i16_i8 x)-  let i32 (x: i32) = unsign (intrinsics.zext_i32_i8 x)-  let i64 (x: i64) = unsign (intrinsics.zext_i64_i8 x)--  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i8 x)-  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i8 x)--  let bool x = unsign (intrinsics.btoi_bool_i8 x)--  let to_i32(x: u8) = intrinsics.zext_i8_i32 (sign x)-  let to_i64(x: u8) = intrinsics.zext_i8_i64 (sign x)--  let (x: u8) == (y: u8) = intrinsics.eq_i8 (sign x, sign y)-  let (x: u8) < (y: u8) = intrinsics.ult8 (sign x, sign y)-  let (x: u8) > (y: u8) = intrinsics.ult8 (sign y, sign x)-  let (x: u8) <= (y: u8) = intrinsics.ule8 (sign x, sign y)-  let (x: u8) >= (y: u8) = intrinsics.ule8 (sign y, sign x)-  let (x: u8) != (y: u8) = intrinsics.! (x == y)--  let sgn (x: u8) = unsign (intrinsics.usignum8 (sign x))-  let abs (x: u8) = x--  let negate (x: t) = -x-  let max (x: t) (y: t) = unsign (intrinsics.umax8 (sign x, sign y))-  let min (x: t) (y: t) = unsign (intrinsics.umin8 (sign x, sign y))--  let highest = 255u8-  let lowest = 0u8--  let num_bits = 8-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc x = intrinsics.popc8 (sign x)-  let clz x = intrinsics.clz8 (sign x)--  let iota (n: u8) = 0u8..1u8..<n-  let replicate 'v (n: u8) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module u16: (size with t = u16) = {-  type t = u16--  let sign (x: u16) = intrinsics.sign_i16 x-  let unsign (x: i16) = intrinsics.unsign_i16 x--  let (x: u16) + (y: u16) = unsign (intrinsics.add16 (sign x, sign y))-  let (x: u16) - (y: u16) = unsign (intrinsics.sub16 (sign x, sign y))-  let (x: u16) * (y: u16) = unsign (intrinsics.mul16 (sign x, sign y))-  let (x: u16) / (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))-  let (x: u16) ** (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))-  let (x: u16) % (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))-  let (x: u16) // (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))-  let (x: u16) %% (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))--  let (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x, sign y))-  let (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x, sign y))-  let (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x, sign y))-  let ! (x: u16) = unsign (intrinsics.complement16 (sign x))--  let (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x, sign y))-  let (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y))-  let (x: u16) >>> (y: u16) = unsign (intrinsics.lshr16 (sign x, sign y))--  let u8  (x: u8)  = unsign (i16.u8 x)-  let u16 (x: u16) = unsign (i16.u16 x)-  let u32 (x: u32) = unsign (i16.u32 x)-  let u64 (x: u64) = unsign (i16.u64 x)--  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i16 x)-  let i16 (x: i16) = unsign (intrinsics.zext_i16_i16 x)-  let i32 (x: i32) = unsign (intrinsics.zext_i32_i16 x)-  let i64 (x: i64) = unsign (intrinsics.zext_i64_i16 x)--  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i16 x)-  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i16 x)--  let bool x = unsign (intrinsics.btoi_bool_i16 x)--  let to_i32(x: u16) = intrinsics.zext_i16_i32 (sign x)-  let to_i64(x: u16) = intrinsics.zext_i16_i64 (sign x)--  let (x: u16) == (y: u16) = intrinsics.eq_i16 (sign x, sign y)-  let (x: u16) < (y: u16) = intrinsics.ult16 (sign x, sign y)-  let (x: u16) > (y: u16) = intrinsics.ult16 (sign y, sign x)-  let (x: u16) <= (y: u16) = intrinsics.ule16 (sign x, sign y)-  let (x: u16) >= (y: u16) = intrinsics.ule16 (sign y, sign x)-  let (x: u16) != (y: u16) = intrinsics.! (x == y)--  let sgn (x: u16) = unsign (intrinsics.usignum16 (sign x))-  let abs (x: u16) = x--  let negate (x: t) = -x-  let max (x: t) (y: t) = unsign (intrinsics.umax16 (sign x, sign y))-  let min (x: t) (y: t) = unsign (intrinsics.umin16 (sign x, sign y))--  let highest = 65535u16-  let lowest = 0u16--  let num_bits = 16-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc x = intrinsics.popc16 (sign x)-  let clz x = intrinsics.clz16 (sign x)--  let iota (n: u16) = 0u16..1u16..<n-  let replicate 'v (n: u16) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module u32: (size with t = u32) = {-  type t = u32--  let sign (x: u32) = intrinsics.sign_i32 x-  let unsign (x: i32) = intrinsics.unsign_i32 x--  let (x: u32) + (y: u32) = unsign (intrinsics.add32 (sign x, sign y))-  let (x: u32) - (y: u32) = unsign (intrinsics.sub32 (sign x, sign y))-  let (x: u32) * (y: u32) = unsign (intrinsics.mul32 (sign x, sign y))-  let (x: u32) / (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))-  let (x: u32) ** (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))-  let (x: u32) % (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))-  let (x: u32) // (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))-  let (x: u32) %% (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))--  let (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x, sign y))-  let (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x, sign y))-  let (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x, sign y))-  let ! (x: u32) = unsign (intrinsics.complement32 (sign x))--  let (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x, sign y))-  let (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y))-  let (x: u32) >>> (y: u32) = unsign (intrinsics.lshr32 (sign x, sign y))--  let u8  (x: u8)  = unsign (i32.u8 x)-  let u16 (x: u16) = unsign (i32.u16 x)-  let u32 (x: u32) = unsign (i32.u32 x)-  let u64 (x: u64) = unsign (i32.u64 x)--  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i32 x)-  let i16 (x: i16) = unsign (intrinsics.zext_i16_i32 x)-  let i32 (x: i32) = unsign (intrinsics.zext_i32_i32 x)-  let i64 (x: i64) = unsign (intrinsics.zext_i64_i32 x)--  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i32 x)-  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i32 x)--  let bool x = unsign (intrinsics.btoi_bool_i32 x)--  let to_i32(x: u32) = intrinsics.zext_i32_i32 (sign x)-  let to_i64(x: u32) = intrinsics.zext_i32_i64 (sign x)--  let (x: u32) == (y: u32) = intrinsics.eq_i32 (sign x, sign y)-  let (x: u32) < (y: u32) = intrinsics.ult32 (sign x, sign y)-  let (x: u32) > (y: u32) = intrinsics.ult32 (sign y, sign x)-  let (x: u32) <= (y: u32) = intrinsics.ule32 (sign x, sign y)-  let (x: u32) >= (y: u32) = intrinsics.ule32 (sign y, sign x)-  let (x: u32) != (y: u32) = intrinsics.! (x == y)--  let sgn (x: u32) = unsign (intrinsics.usignum32 (sign x))-  let abs (x: u32) = x--  let highest = 4294967295u32-  let lowest = highest + 1u32--  let negate (x: t) = -x-  let max (x: t) (y: t) = unsign (intrinsics.umax32 (sign x, sign y))-  let min (x: t) (y: t) = unsign (intrinsics.umin32 (sign x, sign y))--  let num_bits = 32-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc x = intrinsics.popc32 (sign x)-  let clz x = intrinsics.clz32 (sign x)--  let iota (n: u32) = 0u32..1u32..<n-  let replicate 'v (n: u32) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module u64: (size with t = u64) = {-  type t = u64--  let sign (x: u64) = intrinsics.sign_i64 x-  let unsign (x: i64) = intrinsics.unsign_i64 x--  let (x: u64) + (y: u64) = unsign (intrinsics.add64 (sign x, sign y))-  let (x: u64) - (y: u64) = unsign (intrinsics.sub64 (sign x, sign y))-  let (x: u64) * (y: u64) = unsign (intrinsics.mul64 (sign x, sign y))-  let (x: u64) / (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))-  let (x: u64) ** (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))-  let (x: u64) % (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))-  let (x: u64) // (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))-  let (x: u64) %% (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))--  let (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x, sign y))-  let (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x, sign y))-  let (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x, sign y))-  let ! (x: u64) = unsign (intrinsics.complement64 (sign x))--  let (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x, sign y))-  let (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y))-  let (x: u64) >>> (y: u64) = unsign (intrinsics.lshr64 (sign x, sign y))--  let u8  (x: u8)  = unsign (i64.u8 x)-  let u16 (x: u16) = unsign (i64.u16 x)-  let u32 (x: u32) = unsign (i64.u32 x)-  let u64 (x: u64) = unsign (i64.u64 x)--  let i8 (x: i8)   = unsign (intrinsics.zext_i8_i64 x)-  let i16 (x: i16) = unsign (intrinsics.zext_i16_i64 x)-  let i32 (x: i32) = unsign (intrinsics.zext_i32_i64 x)-  let i64 (x: i64) = unsign (intrinsics.zext_i64_i64 x)--  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i64 x)-  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i64 x)--  let bool x = unsign (intrinsics.btoi_bool_i64 x)--  let to_i32(x: u64) = intrinsics.zext_i64_i32 (sign x)-  let to_i64(x: u64) = intrinsics.zext_i64_i64 (sign x)--  let (x: u64) == (y: u64) = intrinsics.eq_i64 (sign x, sign y)-  let (x: u64) < (y: u64) = intrinsics.ult64 (sign x, sign y)-  let (x: u64) > (y: u64) = intrinsics.ult64 (sign y, sign x)-  let (x: u64) <= (y: u64) = intrinsics.ule64 (sign x, sign y)-  let (x: u64) >= (y: u64) = intrinsics.ule64 (sign y, sign x)-  let (x: u64) != (y: u64) = intrinsics.! (x == y)--  let sgn (x: u64) = unsign (intrinsics.usignum64 (sign x))-  let abs (x: u64) = x--  let negate (x: t) = -x-  let max (x: t) (y: t) = unsign (intrinsics.umax64 (sign x, sign y))-  let min (x: t) (y: t) = unsign (intrinsics.umin64 (sign x, sign y))--  let highest = 18446744073709551615u64-  let lowest = highest + 1u64--  let num_bits = 64-  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)-  let set_bit (bit: i32) (x: t) (b: i32) =-    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))-  let popc x = intrinsics.popc64 (sign x)-  let clz x = intrinsics.clz64 (sign x)--  let iota (n: u64) = 0u64..1u64..<n-  let replicate 'v (n: u64) (x: v) = map (const x) (iota n)--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module f64: (float with t = f64 with int_t = u64) = {-  type t = f64-  type int_t = u64--  module i64m = i64-  module u64m = u64--  let (x: f64) + (y: f64) = intrinsics.fadd64 (x, y)-  let (x: f64) - (y: f64) = intrinsics.fsub64 (x, y)-  let (x: f64) * (y: f64) = intrinsics.fmul64 (x, y)-  let (x: f64) / (y: f64) = intrinsics.fdiv64 (x, y)-  let (x: f64) % (y: f64) = intrinsics.fmod64 (x, y)-  let (x: f64) ** (y: f64) = intrinsics.fpow64 (x, y)--  let u8  (x: u8)  = intrinsics.uitofp_i8_f64  (i8.u8 x)-  let u16 (x: u16) = intrinsics.uitofp_i16_f64 (i16.u16 x)-  let u32 (x: u32) = intrinsics.uitofp_i32_f64 (i32.u32 x)-  let u64 (x: u64) = intrinsics.uitofp_i64_f64 (i64.u64 x)--  let i8 (x: i8) = intrinsics.sitofp_i8_f64 x-  let i16 (x: i16) = intrinsics.sitofp_i16_f64 x-  let i32 (x: i32) = intrinsics.sitofp_i32_f64 x-  let i64 (x: i64) = intrinsics.sitofp_i64_f64 x--  let f32 (x: f32) = intrinsics.fpconv_f32_f64 x-  let f64 (x: f64) = intrinsics.fpconv_f64_f64 x--  let bool (x: bool) = if x then 1f64 else 0f64--  let from_fraction (x: i32) (y: i32) = i32 x / i32 y-  let to_i32 (x: f64) = intrinsics.fptosi_f64_i32 x-  let to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x-  let to_f64 (x: f64) = x--  let (x: f64) == (y: f64) = intrinsics.eq_f64 (x, y)-  let (x: f64) < (y: f64) = intrinsics.lt64 (x, y)-  let (x: f64) > (y: f64) = intrinsics.lt64 (y, x)-  let (x: f64) <= (y: f64) = intrinsics.le64 (x, y)-  let (x: f64) >= (y: f64) = intrinsics.le64 (y, x)-  let (x: f64) != (y: f64) = intrinsics.! (x == y)--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.fmax64 (x, y)-  let min (x: t) (y: t) = intrinsics.fmin64 (x, y)--  let sgn (x: f64) = if      x < 0f64  then -1f64-                     else if x == 0f64 then  0f64-                     else                    1f64-  let abs (x: f64) = intrinsics.fabs64 x--  let sqrt (x: f64) = intrinsics.sqrt64 x--  let log (x: f64) = intrinsics.log64 x-  let log2 (x: f64) = intrinsics.log2_64 x-  let log10 (x: f64) = intrinsics.log10_64 x-  let exp (x: f64) = intrinsics.exp64 x-  let cos (x: f64) = intrinsics.cos64 x-  let sin (x: f64) = intrinsics.sin64 x-  let tan (x: f64) = intrinsics.tan64 x-  let acos (x: f64) = intrinsics.acos64 x-  let asin (x: f64) = intrinsics.asin64 x-  let atan (x: f64) = intrinsics.atan64 x-  let atan2 (x: f64) (y: f64) = intrinsics.atan2_64 (x, y)-  let gamma = intrinsics.gamma64-  let lgamma = intrinsics.lgamma64-  let lerp v0 v1 t = intrinsics.lerp64 (v0, v1, t)--  let ceil = intrinsics.ceil64-  let floor = intrinsics.floor64-  let trunc (x: f64) : f64 = i64 (i64m.f64 x)--  let round = intrinsics.round64--  let to_bits (x: f64): u64 = u64m.i64 (intrinsics.to_bits64 x)-  let from_bits (x: u64): f64 = intrinsics.from_bits64 (intrinsics.sign_i64 x)--  let num_bits = 64-  let get_bit (bit: i32) (x: t) = u64m.get_bit bit (to_bits x)-  let set_bit (bit: i32) (x: t) (b: i32) = from_bits (u64m.set_bit bit (to_bits x) b)--  let isinf (x: f64) = intrinsics.isinf64 x-  let isnan (x: f64) = intrinsics.isnan64 x--  let inf = 1f64 / 0f64-  let nan = 0f64 / 0f64--  let highest = inf-  let lowest = -inf--  let pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164062f64-  let e = 2.718281828459045235360287471352662497757247093699959574966967627724076630353f64--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}--module f32: (float with t = f32 with int_t = u32) = {-  type t = f32-  type int_t = u32--  module i32m = i32-  module u32m = u32-  module f64m = f64--  let (x: f32) + (y: f32) = intrinsics.fadd32 (x, y)-  let (x: f32) - (y: f32) = intrinsics.fsub32 (x, y)-  let (x: f32) * (y: f32) = intrinsics.fmul32 (x, y)-  let (x: f32) / (y: f32) = intrinsics.fdiv32 (x, y)-  let (x: f32) % (y: f32) = intrinsics.fmod32 (x, y)-  let (x: f32) ** (y: f32) = intrinsics.fpow32 (x, y)--  let u8  (x: u8)  = intrinsics.uitofp_i8_f32  (i8.u8 x)-  let u16 (x: u16) = intrinsics.uitofp_i16_f32 (i16.u16 x)-  let u32 (x: u32) = intrinsics.uitofp_i32_f32 (i32.u32 x)-  let u64 (x: u64) = intrinsics.uitofp_i64_f32 (i64.u64 x)--  let i8 (x: i8) = intrinsics.sitofp_i8_f32 x-  let i16 (x: i16) = intrinsics.sitofp_i16_f32 x-  let i32 (x: i32) = intrinsics.sitofp_i32_f32 x-  let i64 (x: i64) = intrinsics.sitofp_i64_f32 x--  let f32 (x: f32) = intrinsics.fpconv_f32_f32 x-  let f64 (x: f64) = intrinsics.fpconv_f64_f32 x--  let bool (x: bool) = if x then 1f32 else 0f32--  let from_fraction (x: i32) (y: i32) = i32 x / i32 y-  let to_i32 (x: f32) = intrinsics.fptosi_f32_i32 x-  let to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x-  let to_f64 (x: f32) = intrinsics.fpconv_f32_f64 x--  let (x: f32) == (y: f32) = intrinsics.eq_f32 (x, y)-  let (x: f32) < (y: f32) = intrinsics.lt32 (x, y)-  let (x: f32) > (y: f32) = intrinsics.lt32 (y, x)-  let (x: f32) <= (y: f32) = intrinsics.le32 (x, y)-  let (x: f32) >= (y: f32) = intrinsics.le32 (y, x)-  let (x: f32) != (y: f32) = intrinsics.! (x == y)--  let negate (x: t) = -x-  let max (x: t) (y: t) = intrinsics.fmax32 (x, y)-  let min (x: t) (y: t) = intrinsics.fmin32 (x, y)--  let sgn (x: f32) = if      x < 0f32  then -1f32-                     else if x == 0f32 then  0f32-                     else                    1f32-  let abs (x: f32) = intrinsics.fabs32 x--  let sqrt (x: f32) = intrinsics.sqrt32 x--  let log (x: f32) = intrinsics.log32 x-  let log2 (x: f32) = intrinsics.log2_32 x-  let log10 (x: f32) = intrinsics.log10_32 x-  let exp (x: f32) = intrinsics.exp32 x-  let cos (x: f32) = intrinsics.cos32 x-  let sin (x: f32) = intrinsics.sin32 x-  let tan (x: f32) = intrinsics.tan32 x-  let acos (x: f32) = intrinsics.acos32 x-  let asin (x: f32) = intrinsics.asin32 x-  let atan (x: f32) = intrinsics.atan32 x-  let atan2 (x: f32) (y: f32) = intrinsics.atan2_32 (x, y)-  let gamma = intrinsics.gamma32-  let lgamma = intrinsics.lgamma32-  let lerp v0 v1 t = intrinsics.lerp32 (v0, v1, t)--  let ceil = intrinsics.ceil32-  let floor = intrinsics.floor32-  let trunc (x: f32) : f32 = i32 (i32m.f32 x)--  let round = intrinsics.round32--  let to_bits (x: f32): u32 = u32m.i32 (intrinsics.to_bits32 x)-  let from_bits (x: u32): f32 = intrinsics.from_bits32 (intrinsics.sign_i32 x)--  let num_bits = 32-  let get_bit (bit: i32) (x: t) = u32m.get_bit bit (to_bits x)-  let set_bit (bit: i32) (x: t) (b: i32) = from_bits (u32m.set_bit bit (to_bits x) b)--  let isinf (x: f32) = intrinsics.isinf32 x-  let isnan (x: f32) = intrinsics.isnan32 x--  let inf = 1f32 / 0f32-  let nan = 0f32 / 0f32--  let highest = inf-  let lowest = -inf--  let pi = f64 f64m.pi-  let e = f64 f64m.e--  let sum = reduce (+) (i32 0)-  let product = reduce (*) (i32 1)-  let maximum = reduce max lowest-  let minimum = reduce min highest-}
− futlib/prelude.fut 
@@ -1,34 +0,0 @@--- | The default prelude that is implicitly available in all Futhark--- files.--open import "soacs"-open import "array"-open import "math"-open import "functional"---- | Create single-precision float from integer.-let r32 (x: i32): f32 = f32.i32 x--- | Create integer from single-precision float.-let t32 (x: f32): i32 = i32.f32 x---- | Create double-precision float from integer.-let r64 (x: i32): f64 = f64.i32 x--- | Create integer from double-precision float.-let t64 (x: f64): i32 = i32.f64 x---- | Semantically just identity, but serves as an optimisation--- inhibitor.  The compiler will treat this function as a black box.--- You can use this to work around optimisation deficiencies (or--- bugs), although it should hopefully rarely be necessary.-let opaque 't (x: t): t =-  intrinsics.opaque x---- | Semantically just identity, but when run in the interpreter, the--- argument value will be printed.-let trace 't (x: t): t =-  intrinsics.trace x---- | Semantically just identity, but acts as a break point in--- `futhark repl`.-let break 't (x: t): t =-  intrinsics.break x
− futlib/soacs.fut 
@@ -1,251 +0,0 @@--- | Various Second-Order Array Combinators that are operationally--- parallel in a way that can be exploited by the compiler.------ The functions here are all recognised specially by the compiler (or--- built on those that are).  The asymptotic [work and--- span](https://en.wikipedia.org/wiki/Analysis_of_parallel_algorithms)--- is provided for each function, but note that this easily hides very--- substantial constant factors.  For example, `scan`@term is *much*--- slower than `reduce`@term, although they have the same asymptotic--- complexity.------ *Reminder on terminology*: A function `op` is said to be--- *associative* if------     (x `op` y) `op` z == x `op` (y `op` z)------ for all `x`, `y`, `z`.  Similarly, it is *commutative* if------     x `op` y == y `op` x------ The value `o` is a *neutral element* if------     x `op` o == o `op` x == x------ for any `x`.--import "zip"---- | Apply the given function to each element of an array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =-  intrinsics.map (f, as)---- | Apply the given function to each element of a single array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map1 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =-  map f as---- | As `map1`@term, but with one more array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map2 'a 'b [n] 'x (f: a -> b -> x) (as: [n]a) (bs: [n]b): *[n]x =-  map (\(a, b) -> f a b) (zip2 as bs)---- | As `map2`@term, but with one more array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map3 'a 'b 'c [n] 'x (f: a -> b -> c -> x) (as: [n]a) (bs: [n]b) (cs: [n]c): *[n]x =-  map (\(a, b, c) -> f a b c) (zip3 as bs cs)---- | As `map3`@term, but with one more array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map4 'a 'b 'c 'd [n] 'x (f: a -> b -> c -> d -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): *[n]x =-  map (\(a, b, c, d) -> f a b c d) (zip4 as bs cs ds)---- | As `map4`@term, but with one more array.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map5 'a 'b 'c 'd 'e [n] 'x (f: a -> b -> c -> d -> e -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): *[n]x =-  map (\(a, b, c, d, e) -> f a b c d e) (zip5 as bs cs ds es)---- | Reduce the array `as` with `op`, with `ne` as the neutral--- element for `op`.  The function `op` must be associative.  If--- it is not, the return value is unspecified.  If the value returned--- by the operator is an array, it must have the exact same size as--- the neutral element, and that must again have the same size as the--- elements of the input array.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let reduce 'a (op: a -> a -> a) (ne: a) (as: []a): a =-  intrinsics.reduce (op, ne, as)---- | As `reduce`, but the operator must also be commutative.  This is--- potentially faster than `reduce`.  For simple built-in operators,--- like addition, the compiler already knows that the operator is--- commutative, so plain `reduce`@term will work just as well.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let reduce_comm 'a (op: a -> a -> a) (ne: a) (as: []a): a =-  intrinsics.reduce_comm (op, ne, as)---- | `reduce_by_index dest f ne is as` returns `dest`, but with each--- element given by the indices of `is` updated by applying `f` to the--- current value in `dest` and the corresponding value in `as`.  The--- `ne` value must be a neutral element for `op`.  If `is` has--- duplicates, `f` may be applied multiple times, and hence must be--- associative and commutative.  Out-of-bounds indices in `is` are--- ignored.------ **Work:** *O(n)*------ **Span:** *O(n)* in the worst case (all updates to same position),--- but *O(1)* in the best case.------ In practice, the *O(n)* behaviour only occurs if *m* is also very--- large.-let reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i32) (as : [n]a) : *[m]a =-  intrinsics.hist (1, dest, f, ne, is, as)---- | Inclusive prefix scan.  Has the same caveats with respect to--- associativity as `reduce`.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let scan [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): *[n]a =-  intrinsics.scan (op, ne, as)---- | Remove all those elements of `as` that do not satisfy the--- predicate `p`.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let filter 'a (p: a -> bool) (as: []a): *[]a =-  let (as', is) = intrinsics.partition (1, \x -> if p x then 0 else 1, as)-  in as'[:is[0]]---- | Split an array into those elements that satisfy the given--- predicate, and those that do not.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let partition [n] 'a (p: a -> bool) (as: [n]a): ([]a, []a) =-  let p' x = if p x then 0 else 1-  let (as', is) = intrinsics.partition (2, p', as)-  in (as'[0:is[0]], as'[is[0]:n])---- | Split an array by two predicates, producing three arrays.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a): ([]a, []a, []a) =-  let p' x = if p1 x then 0 else if p2 x then 1 else 2-  let (as', is) = intrinsics.partition (3, p', as)-  in (as'[0:is[0]], as'[is[0]:is[0]+is[1]], as'[is[0]+is[1]:n])---- | `reduce_stream op f as` splits `as` into chunks, applies `f` to each--- of these in parallel, and uses `op` (which must be associative) to--- combine the per-chunk results into a final result.  The `i32`--- passed to `f` is the size of the chunk.  This SOAC is useful when--- `f` can be given a particularly work-efficient sequential--- implementation.  Operationally, we can imagine that `as` is divided--- among as many threads as necessary to saturate the machine, with--- each thread operating sequentially.------ A chunk may be empty, and `f 0 []` must produce the neutral element for--- `op`.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let reduce_stream 'a 'b (op: b -> b -> b) (f: i32 -> []a -> b) (as: []a): b =-  intrinsics.reduce_stream (op, f, as)---- | As `reduce_stream`@term, but the chunks do not necessarily--- correspond to subsequences of the original array (they may be--- interleaved).------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let reduce_stream_per 'a 'b (op: b -> b -> b) (f: i32 -> []a -> b) (as: []a): b =-  intrinsics.reduce_stream_per (op, f, as)---- | Similar to `reduce_stream`@term, except that each chunk must produce--- an array *of the same size*.  The per-chunk results are--- concatenated.------ **Work:** *O(n)*------ **Span:** *O(1)*-let map_stream 'a 'b (f: i32 -> []a -> []b) (as: []a): *[]b =-  intrinsics.map_stream (f, as)---- | Similar to `map_stream`@term, but the chunks do not necessarily--- correspond to subsequences of the original array (they may be--- interleaved).------ **Work:** *O(n)*------ **Span:** *O(1)*-let map_stream_per 'a 'b (f: i32 -> []a -> []b) (as: []a): *[]b =-  intrinsics.map_stream_per (f, as)---- | Return `true` if the given function returns `true` for all--- elements in the array.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let all 'a (f: a -> bool) (as: []a): bool =-  reduce (&&) true (map f as)---- | Return `true` if the given function returns `true` for any--- elements in the array.------ **Work:** *O(n)*------ **Span:** *O(log(n))*-let any 'a (f: a -> bool) (as: []a): bool =-  reduce (||) false (map f as)---- | The `scatter as is vs` expression calculates the equivalent of--- this imperative code:------ ```--- for index in 0..length is-1:---   i = is[index]---   v = vs[index]---   as[i] = v--- ```------ The `is` and `vs` arrays must have the same outer size.  `scatter`--- acts in-place and consumes the `as` array, returning a new array--- that has the same type and elements as `as`, except for the indices--- in `is`.  If `is` contains duplicates (i.e. several writes are--- performed to the same location), the result is unspecified.  It is--- not guaranteed that one of the duplicate writes will complete--- atomically - they may be interleaved.  See `reduce_by_index`@term--- for a function that can handle this case deterministically.------ This is technically not a second-order operation, but it is defined--- here because it is closely related to the SOACs.------ **Work:** *O(n)*------ **Span:** *O(1)*-let scatter 't [m] [n] (dest: *[m]t) (is: [n]i32) (vs: [n]t): *[m]t =-  intrinsics.scatter (dest, is, vs)
− futlib/zip.fut 
@@ -1,58 +0,0 @@--- | Transforming arrays of tuples into tuples of arrays and back--- again.  These are generally very cheap operations, as the internal--- compiler representation is always tuples of arrays.---- The main reason this module exists is that we need it to define--- SOACs like `map2`@term@"/futlib/soacs".---- We need a map to define some of the zip variants, but this file is--- depended upon by soacs.fut.  So we just define a quick-and-dirty--- internal one here that uses the intrinsic version.-local let internal_map 'a [n] 'x (f: a -> x) (as: [n]a): [n]x =-  intrinsics.map (f, as)---- | Construct an array of pairs from two arrays.-let zip [n] 'a 'b (as: [n]a) (bs: [n]b): [n](a,b) =-  intrinsics.zip (as, bs)---- | Construct an array of pairs from two arrays.-let zip2 [n] 'a 'b (as: [n]a) (bs: [n]b): [n](a,b) =-  zip as bs---- | As `zip2`@term, but with one more array.-let zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c): [n](a,b,c) =-  internal_map (\(a,(b,c)) -> (a,b,c)) (zip as (zip2 bs cs))---- | As `zip3`@term, but with one more array.-let zip4 [n] 'a 'b 'c 'd (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): [n](a,b,c,d) =-  internal_map (\(a,(b,c,d)) -> (a,b,c,d)) (zip as (zip3 bs cs ds))---- | As `zip4`@term, but with one more array.-let zip5 [n] 'a 'b 'c 'd 'e (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): [n](a,b,c,d,e) =-  internal_map (\(a,(b,c,d,e)) -> (a,b,c,d,e)) (zip as (zip4 bs cs ds es))---- | Turn an array of pairs into two arrays.-let unzip [n] 'a 'b (xs: [n](a,b)): ([n]a, [n]b) =-  intrinsics.unzip xs---- | Turn an array of pairs into two arrays.-let unzip2 [n] 'a 'b (xs: [n](a,b)): ([n]a, [n]b) =-  unzip xs---- | As `unzip2`@term, but with one more array.-let unzip3 [n] 'a 'b 'c (xs: [n](a,b,c)): ([n]a, [n]b, [n]c) =-  let (as, bcs) = unzip (internal_map (\(a,b,c) -> (a,(b,c))) xs)-  let (bs, cs) = unzip bcs-  in (as, bs, cs)---- | As `unzip3`@term, but with one more array.-let unzip4 [n] 'a 'b 'c 'd (xs: [n](a,b,c,d)): ([n]a, [n]b, [n]c, [n]d) =-  let (as, bs, cds) = unzip3 (internal_map (\(a,b,c,d) -> (a,b,(c,d))) xs)-  let (cs, ds) = unzip cds-  in (as, bs, cs, ds)---- | As `unzip4`@term, but with one more array.-let unzip5 [n] 'a 'b 'c 'd 'e (xs: [n](a,b,c,d,e)): ([n]a, [n]b, [n]c, [n]d, [n]e) =-  let (as, bs, cs, des) = unzip4 (internal_map (\(a,b,c,d,e) -> (a,b,c,(d,e))) xs)-  let (ds, es) = unzip des-  in (as, bs, cs, ds, es)
− package.yaml 
@@ -1,119 +0,0 @@-name: futhark-version: "0.14.1"-synopsis: An optimising compiler for a functional, array-oriented language.-description: |-  Futhark is a small programming language designed to be compiled to-  efficient parallel code. It is a statically typed, data-parallel,-  and purely functional array language in the ML family, and comes-  with a heavily optimising ahead-of-time compiler that presently-  generates GPU code via CUDA and OpenCL, although the language itself-  is hardware-agnostic.--  For more information, see the website at https://futhark-lang.org-homepage: https://futhark-lang.org-maintainer: Troels Henriksen athas@sigkill.dk-license: ISC-github: diku-dk/futhark-category: Language--ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists--extra-source-files:-  - rts/python/*.py-  - rts/c/*.h-  - rts/csharp/*.cs-  - rts/futhark-doc/*.css--  - futlib/*.fut--  - docs/Makefile-  - docs/conf.py-  - docs/index.rst-  - docs/man/*.rst-  - package.yaml--library:-  dependencies:-    - base >= 4.13 && < 5-    - array >= 0.4-    - binary >= 0.8.3-    - data-binary-ieee754 >= 0.1-    - vector >= 0.12-    - vector-binary-instances >= 0.2.2.0-    - containers >= 0.6.2.1-    - mtl >= 2.2.1-    - transformers >= 0.3-    - srcloc >= 0.4-    - language-c-quote >= 0.12-    - mainland-pretty >= 0.6.1-    - megaparsec >= 8.0.0-    - parser-combinators >= 1.0.0-    - regex-tdfa >= 1.2-    - filepath >= 1.4.1.1-    - dlist >= 0.6.0.1-    - bytestring >= 0.10.8-    - text >= 1.2.2.2-    - neat-interpolation >= 0.3-    - file-embed >= 0.0.9-    - directory >= 1.3.0.0-    - directory-tree >= 0.12.1-    - gitrev >= 1.2.0-    - parallel >= 3.2.1.0-    - blaze-html >= 0.9.0.1-    - template-haskell >= 2.11.1-    - process >= 1.4.3.0-    - markdown >= 0.1.16-    - zlib >= 0.6.1.2-    - versions >= 3.3.1-    - http-client >= 0.5.7.0-    - http-client-tls >= 0.3.5.1-    - http-conduit >= 2.2.4-    - process-extras >= 0.7.2-    - free >= 4.12.4-    - zip-archive >= 0.3.1.1-    - time >= 1.6.0.1-    - ansi-terminal >= 0.6.3.1-    - random-    - temporary-    - aeson >= 1.0.0.0-    - haskeline-    - utf8-string >= 1-    - terminal-size >= 0.3-    - unordered-containers >= 0.2.7--  build-tools:-    - alex-    - happy--  source-dirs: src--  other-modules:-    - Language.Futhark.Parser.Parser-    - Language.Futhark.Parser.Lexer-    - Paths_futhark--executables:-  futhark: &futhark-    main: src/futhark.hs-    dependencies:-      - base-      - futhark-      - text-    ghc-options: -threaded -rtsopts "-with-rtsopts=-N -qg"--tests:-  unit:-    source-dirs: unittests-    main: futhark_tests.hs-    dependencies:-      - base-      - futhark-      - containers-      - mtl-      - text-      - QuickCheck >= 2.8-      - tasty-      - tasty-quickcheck-      - tasty-hunit-      - megaparsec-      - parser-combinators
+ prelude/array.fut view
@@ -0,0 +1,134 @@+-- | Utility functions for arrays.++import "math"+import "soacs"+import "functional"+open import "zip" -- Rexport.++-- | The size of the outer dimension of an array.+let length [n] 't (_: [n]t) = n++-- | Is the array empty?+let null [n] 't (_: [n]t) = n == 0++-- | The first element of the array.+let head [n] 't (x: [n]t) = x[0]++-- | The last element of the array.+let last [n] 't (x: [n]t) = x[n-1]++-- | Everything but the first element of the array.+let tail [n] 't (x: [n]t) = x[1:]++-- | Everything but the last element of the array.+let init [n] 't (x: [n]t) = x[0:n-1]++-- | Take some number of elements from the head of the array.+let take [n] 't (i: i32) (x: [n]t): [i]t = x[0:i]++-- | Remove some number of elements from the head of the array.+let drop [n] 't (i: i32) (x: [n]t) = x[i:]++-- | Split an array at a given position.+let split [n] 't (i: i32) (xs: [n]t): ([i]t, []t) =+  (xs[:i] :> [i]t, xs[i:])++-- | Return the elements of the array in reverse order.+let reverse [n] 't (x: [n]t): [n]t = x[::-1] :> [n]t++-- | Concatenate two arrays.  Warning: never try to perform a reduction+-- with this operator; it will not work.+let (++) [n] [m] 't (xs: [n]t) (ys: [m]t): *[]t = intrinsics.concat (xs, ys)++-- | An old-fashioned way of saying `++`.+let concat [n] [m] 't (xs: [n]t) (ys: [m]t): *[]t = xs ++ ys++-- | Concatenation where the result has a predetermined size.  If the+-- provided size is wrong, the function will fail with a run-time+-- error.+let concat_to 't (n: i32) (xs: []t) (ys: []t): *[]t = xs ++ ys :> [n]t++-- | Rotate an array some number of elements to the left.  A negative+-- rotation amount is also supported.+--+-- For example, if `b==rotate r a`, then `b[x+r] = a[x]`.+let rotate [n] 't (r: i32) (xs: [n]t): [n]t = intrinsics.rotate (r, xs) :> [n]t++-- | Construct an array of consecutive integers of the given length,+-- starting at 0.+let iota (n: i32): *[n]i32 =+  i32.iota n :> [n]i32++-- | Construct an array comprising valid indexes into some other+-- array, starting at 0.+let indices [n] 't (_: [n]t) : *[n]i32 =+  iota n++-- | Construct an array of the given length containing the given+-- value.+let replicate 't (n: i32) (x: t): *[n]t =+  i32.replicate n x :> [n]t++-- | Copy a value.  The result will not alias anything.+let copy 't (a: t): *t =+  ([a])[0]++-- | Combines the outer two dimensions of an array.+let flatten [n][m] 't (xs: [n][m]t): []t =+  intrinsics.flatten xs++-- | Like `flatten`@term, but where the final size is known.  Fails at+-- runtime if the provided size is wrong.+let flatten_to [n][m] 't (l: i32) (xs: [n][m]t): [l]t =+  flatten xs :> [l]t++-- | Combines the outer three dimensions of an array.+let flatten_3d [n][m][l] 't (xs: [n][m][l]t): []t =+  flatten (flatten xs)++-- | Combines the outer four dimensions of an array.+let flatten_4d [n][m][l][k] 't (xs: [n][m][l][k]t): []t =+  flatten (flatten_3d xs)++-- | Splits the outer dimension of an array in two.+let unflatten [p] 't (n: i32) (m: i32) (xs: [p]t): [n][m]t =+  intrinsics.unflatten (n, m, xs) :> [n][m]t++-- | Splits the outer dimension of an array in three.+let unflatten_3d [p] 't (n: i32) (m: i32) (l: i32) (xs: [p]t): [n][m][l]t =+  unflatten n m (unflatten (n*m) l xs)++-- | Splits the outer dimension of an array in four.+let unflatten_4d [p] 't (n: i32) (m: i32) (l: i32) (k: i32) (xs: [p]t): [n][m][l][k]t =+  unflatten n m (unflatten_3d (n*m) l k xs)++let transpose [n] [m] 't (a: [n][m]t): [m][n]t =+  intrinsics.transpose a :> [m][n]t++-- | True if all of the input elements are true.  Produces true on an+-- empty array.+let and: []bool -> bool = all id++-- | True if any of the input elements are true.  Produces false on an+-- empty array.+let or: []bool -> bool = any id++-- | Perform a *sequential* left-fold of an array.+let foldl [n] 'a 'b (f: a -> b -> a) (acc: a) (bs: [n]b): a =+  loop acc for b in bs do f acc b++-- | Perform a *sequential* right-fold of an array.+let foldr [n] 'a 'b (f: b -> a -> a) (acc: a) (bs: [n]b): a =+  foldl (flip f) acc (reverse bs)++-- | Create a value for each point in a one-dimensional index space.+let tabulate 'a (n: i32) (f: i32 -> a): *[n]a =+  map1 f (iota n)++-- | Create a value for each point in a two-dimensional index space.+let tabulate_2d 'a (n: i32) (m: i32) (f: i32 -> i32 -> a): *[n][m]a =+  map1 (f >-> tabulate m) (iota n)++-- | Create a value for each point in a three-dimensional index space.+let tabulate_3d 'a (n: i32) (m: i32) (o: i32) (f: i32 -> i32 -> i32 -> a): *[n][m][o]a =+  map1 (f >-> tabulate_2d m o) (iota n)
+ prelude/functional.fut view
@@ -0,0 +1,57 @@+-- | Simple functional combinators.++-- | Left-to-right application.  Particularly useful for describing+-- computation pipelines:+--+-- ```+-- x |> f |> g |> h+-- ```+let (|>) '^a '^b (x: a) (f: a -> b): b = f x++-- | Right to left application.+let (<|) '^a '^b (f: a -> b) (x: a) = f x++-- | Function composition, with values flowing from left to right.+let (>->) '^a '^b '^c (f: a -> b) (g: b -> c) (x: a): c = g (f x)++-- | Function composition, with values flowing from right to left.+-- This is the same as the `∘` operator known from mathematics.+let (<-<) '^a '^b '^c (g: b -> c) (f: a -> b) (x: a): c = g (f x)++-- | Flip the arguments passed to a function.+--+-- ```+-- f x y == flip f y x+-- ```+let flip '^a '^b '^c (f: a -> b -> c) (b: b) (a: a): c =+  f a b++-- | Transform a function taking a pair into a function taking two+-- arguments.+let curry '^a '^b '^c (f: (a, b) -> c) (a: a) (b: b): c =+  f (a, b)++-- | Transform a function taking two arguments in a function taking a+-- pair.+let uncurry '^a '^b '^c (f: a -> b -> c) (a: a, b: b): c =+  f a b++-- | The constant function.+let const '^a '^b (x: a) (_: b): a = x++-- | The identity function.+let id '^a (x: a) = x++-- | Apply a function some number of times.+let iterate 'a (n: i32) (f: a -> a) (x: a) =+  loop x for _i < n do f x++-- | Keep applying `f` until `p` returns true for the input value.+-- May apply zero times.  *Note*: may not terminate.+let iterate_until 'a (p: a -> bool) (f: a -> a) (x: a) =+  loop x while ! (p x) do f x++-- | Keep applying `f` while `p` returns true for the input value.+-- May apply zero times.  *Note*: may not terminate.+let iterate_while 'a (p: a -> bool) (f: a -> a) (x: a) =+  loop x while p x do f x
+ prelude/math.fut view
@@ -0,0 +1,1060 @@+-- | Basic mathematical modules and functions.++import "soacs"++local let const 'a 'b (x: a) (_: b): a = x++-- | Describes types of values that can be created from the primitive+-- numeric types (and bool).+module type from_prim = {+  type t++  val i8: i8 -> t+  val i16: i16 -> t+  val i32: i32 -> t+  val i64: i64 -> t++  val u8: u8 -> t+  val u16: u16 -> t+  val u32: u32 -> t+  val u64: u64 -> t++  val f32: f32 -> t+  val f64: f64 -> t++  val bool: bool -> t+}++-- | A basic numeric module type that can be implemented for both+-- integers and rational numbers.+module type numeric = {+  include from_prim++  val +: t -> t -> t+  val -: t -> t -> t+  val *: t -> t -> t+  val /: t -> t -> t+  val %: t -> t -> t+  val **: t -> t -> t++  val to_i64: t -> i64++  val ==: t -> t -> bool+  val <: t -> t -> bool+  val >: t -> t -> bool+  val <=: t -> t -> bool+  val >=: t -> t -> bool+  val !=: t -> t -> bool++  val negate: t-> t+  val max: t -> t -> t+  val min: t -> t -> t++  val abs: t -> t++  val sgn: t -> t++  -- | The highest representable number.+  val highest: t++  -- | The lowest representable number.+  val lowest: t++  -- | Returns zero on empty input.+  val sum [n]: [n]t -> t++  -- | Returns one on empty input.+  val product [n]: [n]t -> t++  -- | Returns `lowest` on empty input.+  val maximum [n]: [n]t -> t+  -- | Returns `highest` on empty input.+  val minimum [n]: [n]t -> t+}++-- | An extension of `numeric`@mtype that provides facilities that are+-- only meaningful for integral types.+module type integral = {+  include numeric++  -- | Like `/`@term, but rounds towards zero.  This only matters when+  -- one of the operands is negative.  May be more efficient.+  val //: t -> t -> t+  -- | Like `%`@term, but rounds towards zero.  This only matters when+  -- one of the operands is negative.  May be more efficient.+  val %%: t -> t -> t++  val &: t -> t -> t+  val |: t -> t -> t+  val ^: t -> t -> t+  val !: t -> t++  val <<: t -> t -> t+  val >>: t -> t -> t+  val >>>: t -> t -> t++  val num_bits: i32+  val get_bit: i32 -> t -> i32+  val set_bit: i32 -> t -> i32 -> t++  -- | Count number of one bits.+  val popc: t -> i32++  -- | Computes `x * y` and returns the high half of the product of x+  -- and y.+  val mul_hi: (x: t) -> (y: t) -> t++  -- | Computes `mul_hi a b + c`, but perhaps in a more efficient way,+  -- depending on the target platform.+  val mad_hi: (a: t) -> (b: t) -> (c: t) -> t++  -- | Count number of zero bits preceding the most significant set+  -- bit.+  val clz: t -> i32+}++-- | An extension of `size`@mtype that further includes facilities for+-- constructing arrays where the size is provided as a value of the+-- given integral type.+module type size = {+  include integral++  val iota: t -> *[]t+  val replicate 'v: t -> v -> *[]v+}++-- | Numbers that model real numbers to some degree.+module type real = {+  include numeric++  val from_fraction: i32 -> i32 -> t+  val to_i32: t -> i32+  val to_i64: t -> i64+  val to_f64: t -> f64++  val sqrt: t -> t+  val exp: t -> t++  val sin: t -> t+  val cos: t -> t+  val tan: t -> t++  val asin: t -> t+  val acos: t -> t+  val atan: t -> t++  val sinh: t -> t+  val cosh: t -> t+  val tanh: t -> t++  val asinh: t -> t+  val acosh: t -> t+  val atanh: t -> t++  val atan2: t -> t -> t++  val gamma: t -> t+  val lgamma: t -> t+  -- | Linear interpolation.  The third argument must be in the range+  -- `[0,1]` or the results are unspecified.+  val lerp: t -> t -> t -> t++  -- | Natural logarithm.+  val log: t -> t+  -- | Base-2 logarithm.+  val log2: t -> t+  -- | Base-10 logarithm.+  val log10: t -> t++  val ceil : t -> t+  val floor : t -> t+  val trunc : t -> t++  -- | Computes `a*b+c`.  Depending on the compiler backend, this may+  -- be fused into a single operation that is faster but less+  -- accurate.  Do not confuse it with `fma`@term.+  val mad : (a: t) -> (b: t) -> (c: t) -> t++  -- | Computes `a*b+c`, with `a*b` being rounded with infinite+  -- precision.  Rounding of intermediate products shall not+  -- occur. Edge case behavior is per the IEEE 754-2008 standard.+  val fma : (a: t) -> (b: t) -> (c: t) -> t++  -- | Round to the nearest integer, with alfway cases rounded to the+  -- nearest even integer.  Note that this differs from `round()` in+  -- C, but matches more modern languages.+  val round : t -> t++  val isinf: t -> bool+  val isnan: t -> bool++  val inf: t+  val nan: t++  val pi: t+  val e: t+}++-- | An extension of `real`@mtype that further gives access to the+-- bitwise representation of the underlying number.  It is presumed+-- that this will be some form of IEEE float.+module type float = {+  include real++  -- | An unsigned integer type containing the same number of bits as+  -- 't'.+  type int_t++  val from_bits: int_t -> t+  val to_bits: t -> int_t++  val num_bits: i32+  val get_bit: i32 -> t -> i32+  val set_bit: i32 -> t -> i32 -> t+}++-- | Boolean numbers.  When converting from a number to `bool`, 0 is+-- considered `false` and any other value is `true`.+module bool: from_prim with t = bool = {+  type t = bool++  let i8  = intrinsics.itob_i8_bool+  let i16 = intrinsics.itob_i16_bool+  let i32 = intrinsics.itob_i32_bool+  let i64 = intrinsics.itob_i64_bool++  let u8  (x: u8)  = intrinsics.itob_i8_bool (intrinsics.sign_i8 x)+  let u16 (x: u16) = intrinsics.itob_i16_bool (intrinsics.sign_i16 x)+  let u32 (x: u32) = intrinsics.itob_i32_bool (intrinsics.sign_i32 x)+  let u64 (x: u64) = intrinsics.itob_i64_bool (intrinsics.sign_i64 x)++  let f32 (x: f32) = x != 0f32+  let f64 (x: f64) = x != 0f64++  let bool (x: bool) = x+}++module i8: (size with t = i8) = {+  type t = i8++  let (x: i8) + (y: i8) = intrinsics.add8 (x, y)+  let (x: i8) - (y: i8) = intrinsics.sub8 (x, y)+  let (x: i8) * (y: i8) = intrinsics.mul8 (x, y)+  let (x: i8) / (y: i8) = intrinsics.sdiv8 (x, y)+  let (x: i8) ** (y: i8) = intrinsics.pow8 (x, y)+  let (x: i8) % (y: i8) = intrinsics.smod8 (x, y)+  let (x: i8) // (y: i8) = intrinsics.squot8 (x, y)+  let (x: i8) %% (y: i8) = intrinsics.srem8 (x, y)++  let (x: i8) & (y: i8) = intrinsics.and8 (x, y)+  let (x: i8) | (y: i8) = intrinsics.or8 (x, y)+  let (x: i8) ^ (y: i8) = intrinsics.xor8 (x, y)+  let ! (x: i8) = intrinsics.complement8 x++  let (x: i8) << (y: i8) = intrinsics.shl8 (x, y)+  let (x: i8) >> (y: i8) = intrinsics.ashr8 (x, y)+  let (x: i8) >>> (y: i8) = intrinsics.lshr8 (x, y)++  let i8  (x: i8)  = intrinsics.sext_i8_i8 x+  let i16 (x: i16) = intrinsics.sext_i16_i8 x+  let i32 (x: i32) = intrinsics.sext_i32_i8 x+  let i64 (x: i64) = intrinsics.sext_i64_i8 x++  let u8  (x: u8)  = intrinsics.zext_i8_i8 (intrinsics.sign_i8 x)+  let u16 (x: u16) = intrinsics.zext_i16_i8 (intrinsics.sign_i16 x)+  let u32 (x: u32) = intrinsics.zext_i32_i8 (intrinsics.sign_i32 x)+  let u64 (x: u64) = intrinsics.zext_i64_i8 (intrinsics.sign_i64 x)++  let f32 (x: f32) = intrinsics.fptosi_f32_i8 x+  let f64 (x: f64) = intrinsics.fptosi_f64_i8 x++  let bool = intrinsics.btoi_bool_i8++  let to_i32(x: i8) = intrinsics.sext_i8_i32 x+  let to_i64(x: i8) = intrinsics.sext_i8_i64 x++  let (x: i8) == (y: i8) = intrinsics.eq_i8 (x, y)+  let (x: i8) < (y: i8) = intrinsics.slt8 (x, y)+  let (x: i8) > (y: i8) = intrinsics.slt8 (y, x)+  let (x: i8) <= (y: i8) = intrinsics.sle8 (x, y)+  let (x: i8) >= (y: i8) = intrinsics.sle8 (y, x)+  let (x: i8) != (y: i8) = intrinsics.! (x == y)++  let sgn (x: i8) = intrinsics.ssignum8 x+  let abs (x: i8) = intrinsics.abs8 x++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.smax8 (x, y)+  let min (x: t) (y: t) = intrinsics.smin8 (x, y)++  let highest = 127i8+  let lowest = highest + 1i8++  let num_bits = 8+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc = intrinsics.popc8+  let mul_hi a b = intrinsics.mul_hi8 (i8 a, i8 b)+  let mad_hi a b c = intrinsics.mad_hi8 (i8 a, i8 b, i8 c)+  let clz = intrinsics.clz8++  let iota (n: i8) = 0i8..1i8..<n+  let replicate 'v (n: i8) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module i16: (size with t = i16) = {+  type t = i16++  let (x: i16) + (y: i16) = intrinsics.add16 (x, y)+  let (x: i16) - (y: i16) = intrinsics.sub16 (x, y)+  let (x: i16) * (y: i16) = intrinsics.mul16 (x, y)+  let (x: i16) / (y: i16) = intrinsics.sdiv16 (x, y)+  let (x: i16) ** (y: i16) = intrinsics.pow16 (x, y)+  let (x: i16) % (y: i16) = intrinsics.smod16 (x, y)+  let (x: i16) // (y: i16) = intrinsics.squot16 (x, y)+  let (x: i16) %% (y: i16) = intrinsics.srem16 (x, y)++  let (x: i16) & (y: i16) = intrinsics.and16 (x, y)+  let (x: i16) | (y: i16) = intrinsics.or16 (x, y)+  let (x: i16) ^ (y: i16) = intrinsics.xor16 (x, y)+  let ! (x: i16) = intrinsics.complement16 x++  let (x: i16) << (y: i16) = intrinsics.shl16 (x, y)+  let (x: i16) >> (y: i16) = intrinsics.ashr16 (x, y)+  let (x: i16) >>> (y: i16) = intrinsics.lshr16 (x, y)++  let i8  (x: i8)  = intrinsics.sext_i8_i16 x+  let i16 (x: i16) = intrinsics.sext_i16_i16 x+  let i32 (x: i32) = intrinsics.sext_i32_i16 x+  let i64 (x: i64) = intrinsics.sext_i64_i16 x++  let u8  (x: u8)  = intrinsics.zext_i8_i16 (intrinsics.sign_i8 x)+  let u16 (x: u16) = intrinsics.zext_i16_i16 (intrinsics.sign_i16 x)+  let u32 (x: u32) = intrinsics.zext_i32_i16 (intrinsics.sign_i32 x)+  let u64 (x: u64) = intrinsics.zext_i64_i16 (intrinsics.sign_i64 x)++  let f32 (x: f32) = intrinsics.fptosi_f32_i16 x+  let f64 (x: f64) = intrinsics.fptosi_f64_i16 x++  let bool = intrinsics.btoi_bool_i16++  let to_i32(x: i16) = intrinsics.sext_i16_i32 x+  let to_i64(x: i16) = intrinsics.sext_i16_i64 x++  let (x: i16) == (y: i16) = intrinsics.eq_i16 (x, y)+  let (x: i16) < (y: i16) = intrinsics.slt16 (x, y)+  let (x: i16) > (y: i16) = intrinsics.slt16 (y, x)+  let (x: i16) <= (y: i16) = intrinsics.sle16 (x, y)+  let (x: i16) >= (y: i16) = intrinsics.sle16 (y, x)+  let (x: i16) != (y: i16) = intrinsics.! (x == y)++  let sgn (x: i16) = intrinsics.ssignum16 x+  let abs (x: i16) = intrinsics.abs16 x++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.smax16 (x, y)+  let min (x: t) (y: t) = intrinsics.smin16 (x, y)++  let highest = 32767i16+  let lowest = highest + 1i16++  let num_bits = 16+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc = intrinsics.popc16+  let mul_hi a b = intrinsics.mul_hi16 (i16 a, i16 b)+  let mad_hi a b c = intrinsics.mad_hi16 (i16 a, i16 b, i16 c)+  let clz = intrinsics.clz16++  let iota (n: i16) = 0i16..1i16..<n+  let replicate 'v (n: i16) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module i32: (size with t = i32) = {+  type t = i32++  let sign (x: u32) = intrinsics.sign_i32 x+  let unsign (x: i32) = intrinsics.unsign_i32 x++  let (x: i32) + (y: i32) = intrinsics.add32 (x, y)+  let (x: i32) - (y: i32) = intrinsics.sub32 (x, y)+  let (x: i32) * (y: i32) = intrinsics.mul32 (x, y)+  let (x: i32) / (y: i32) = intrinsics.sdiv32 (x, y)+  let (x: i32) ** (y: i32) = intrinsics.pow32 (x, y)+  let (x: i32) % (y: i32) = intrinsics.smod32 (x, y)+  let (x: i32) // (y: i32) = intrinsics.squot32 (x, y)+  let (x: i32) %% (y: i32) = intrinsics.srem32 (x, y)++  let (x: i32) & (y: i32) = intrinsics.and32 (x, y)+  let (x: i32) | (y: i32) = intrinsics.or32 (x, y)+  let (x: i32) ^ (y: i32) = intrinsics.xor32 (x, y)+  let ! (x: i32) = intrinsics.complement32 x++  let (x: i32) << (y: i32) = intrinsics.shl32 (x, y)+  let (x: i32) >> (y: i32) = intrinsics.ashr32 (x, y)+  let (x: i32) >>> (y: i32) = intrinsics.lshr32 (x, y)++  let i8  (x: i8)  = intrinsics.sext_i8_i32 x+  let i16 (x: i16) = intrinsics.sext_i16_i32 x+  let i32 (x: i32) = intrinsics.sext_i32_i32 x+  let i64 (x: i64) = intrinsics.sext_i64_i32 x++  let u8  (x: u8)  = intrinsics.zext_i8_i32 (intrinsics.sign_i8 x)+  let u16 (x: u16) = intrinsics.zext_i16_i32 (intrinsics.sign_i16 x)+  let u32 (x: u32) = intrinsics.zext_i32_i32 (intrinsics.sign_i32 x)+  let u64 (x: u64) = intrinsics.zext_i64_i32 (intrinsics.sign_i64 x)++  let f32 (x: f32) = intrinsics.fptosi_f32_i32 x+  let f64 (x: f64) = intrinsics.fptosi_f64_i32 x++  let bool = intrinsics.btoi_bool_i32++  let to_i32(x: i32) = intrinsics.sext_i32_i32 x+  let to_i64(x: i32) = intrinsics.sext_i32_i64 x++  let (x: i32) == (y: i32) = intrinsics.eq_i32 (x, y)+  let (x: i32) < (y: i32) = intrinsics.slt32 (x, y)+  let (x: i32) > (y: i32) = intrinsics.slt32 (y, x)+  let (x: i32) <= (y: i32) = intrinsics.sle32 (x, y)+  let (x: i32) >= (y: i32) = intrinsics.sle32 (y, x)+  let (x: i32) != (y: i32) = intrinsics.! (x == y)++  let sgn (x: i32) = intrinsics.ssignum32 x+  let abs (x: i32) = intrinsics.abs32 x++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.smax32 (x, y)+  let min (x: t) (y: t) = intrinsics.smin32 (x, y)++  let highest = 2147483647+  let lowest = highest + 1++  let num_bits = 32+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc = intrinsics.popc32+  let mul_hi a b = intrinsics.mul_hi32 (i32 a, i32 b)+  let mad_hi a b c = intrinsics.mad_hi32 (i32 a, i32 b, i32 c)+  let clz = intrinsics.clz32++  let iota (n: i32) = 0..1..<n+  let replicate 'v (n: i32) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module i64: (size with t = i64) = {+  type t = i64++  let sign (x: u64) = intrinsics.sign_i64 x+  let unsign (x: i64) = intrinsics.unsign_i64 x++  let (x: i64) + (y: i64) = intrinsics.add64 (x, y)+  let (x: i64) - (y: i64) = intrinsics.sub64 (x, y)+  let (x: i64) * (y: i64) = intrinsics.mul64 (x, y)+  let (x: i64) / (y: i64) = intrinsics.sdiv64 (x, y)+  let (x: i64) ** (y: i64) = intrinsics.pow64 (x, y)+  let (x: i64) % (y: i64) = intrinsics.smod64 (x, y)+  let (x: i64) // (y: i64) = intrinsics.squot64 (x, y)+  let (x: i64) %% (y: i64) = intrinsics.srem64 (x, y)++  let (x: i64) & (y: i64) = intrinsics.and64 (x, y)+  let (x: i64) | (y: i64) = intrinsics.or64 (x, y)+  let (x: i64) ^ (y: i64) = intrinsics.xor64 (x, y)+  let ! (x: i64) = intrinsics.complement64 x++  let (x: i64) << (y: i64) = intrinsics.shl64 (x, y)+  let (x: i64) >> (y: i64) = intrinsics.ashr64 (x, y)+  let (x: i64) >>> (y: i64) = intrinsics.lshr64 (x, y)++  let i8  (x: i8)  = intrinsics.sext_i8_i64 x+  let i16 (x: i16) = intrinsics.sext_i16_i64 x+  let i32 (x: i32) = intrinsics.sext_i32_i64 x+  let i64 (x: i64) = intrinsics.sext_i64_i64 x++  let u8  (x: u8)  = intrinsics.zext_i8_i64 (intrinsics.sign_i8 x)+  let u16 (x: u16) = intrinsics.zext_i16_i64 (intrinsics.sign_i16 x)+  let u32 (x: u32) = intrinsics.zext_i32_i64 (intrinsics.sign_i32 x)+  let u64 (x: u64) = intrinsics.zext_i64_i64 (intrinsics.sign_i64 x)++  let f32 (x: f32) = intrinsics.fptosi_f32_i64 x+  let f64 (x: f64) = intrinsics.fptosi_f64_i64 x++  let bool = intrinsics.btoi_bool_i64++  let to_i32(x: i64) = intrinsics.sext_i64_i32 x+  let to_i64(x: i64) = intrinsics.sext_i64_i64 x++  let (x: i64) == (y: i64) = intrinsics.eq_i64 (x, y)+  let (x: i64) < (y: i64) = intrinsics.slt64 (x, y)+  let (x: i64) > (y: i64) = intrinsics.slt64 (y, x)+  let (x: i64) <= (y: i64) = intrinsics.sle64 (x, y)+  let (x: i64) >= (y: i64) = intrinsics.sle64 (y, x)+  let (x: i64) != (y: i64) = intrinsics.! (x == y)++  let sgn (x: i64) = intrinsics.ssignum64 x+  let abs (x: i64) = intrinsics.abs64 x++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.smax64 (x, y)+  let min (x: t) (y: t) = intrinsics.smin64 (x, y)++  let highest = 9223372036854775807i64+  let lowest = highest + 1i64++  let num_bits = 64+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | intrinsics.zext_i32_i64 (b intrinsics.<< bit))+  let popc = intrinsics.popc64+  let mul_hi a b = intrinsics.mul_hi64 (i64 a, i64 b)+  let mad_hi a b c = intrinsics.mad_hi64 (i64 a, i64 b, i64 c)+  let clz = intrinsics.clz64++  let iota (n: i64) = 0i64..1i64..<n+  let replicate 'v (n: i64) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module u8: (size with t = u8) = {+  type t = u8++  let sign (x: u8) = intrinsics.sign_i8 x+  let unsign (x: i8) = intrinsics.unsign_i8 x++  let (x: u8) + (y: u8) = unsign (intrinsics.add8 (sign x, sign y))+  let (x: u8) - (y: u8) = unsign (intrinsics.sub8 (sign x, sign y))+  let (x: u8) * (y: u8) = unsign (intrinsics.mul8 (sign x, sign y))+  let (x: u8) / (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+  let (x: u8) ** (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))+  let (x: u8) % (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))+  let (x: u8) // (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+  let (x: u8) %% (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))++  let (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x, sign y))+  let (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x, sign y))+  let (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x, sign y))+  let ! (x: u8) = unsign (intrinsics.complement8 (sign x))++  let (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x, sign y))+  let (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y))+  let (x: u8) >>> (y: u8) = unsign (intrinsics.lshr8 (sign x, sign y))++  let u8  (x: u8)  = unsign (i8.u8 x)+  let u16 (x: u16) = unsign (i8.u16 x)+  let u32 (x: u32) = unsign (i8.u32 x)+  let u64 (x: u64) = unsign (i8.u64 x)++  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i8 x)+  let i16 (x: i16) = unsign (intrinsics.zext_i16_i8 x)+  let i32 (x: i32) = unsign (intrinsics.zext_i32_i8 x)+  let i64 (x: i64) = unsign (intrinsics.zext_i64_i8 x)++  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i8 x)+  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i8 x)++  let bool x = unsign (intrinsics.btoi_bool_i8 x)++  let to_i32(x: u8) = intrinsics.zext_i8_i32 (sign x)+  let to_i64(x: u8) = intrinsics.zext_i8_i64 (sign x)++  let (x: u8) == (y: u8) = intrinsics.eq_i8 (sign x, sign y)+  let (x: u8) < (y: u8) = intrinsics.ult8 (sign x, sign y)+  let (x: u8) > (y: u8) = intrinsics.ult8 (sign y, sign x)+  let (x: u8) <= (y: u8) = intrinsics.ule8 (sign x, sign y)+  let (x: u8) >= (y: u8) = intrinsics.ule8 (sign y, sign x)+  let (x: u8) != (y: u8) = intrinsics.! (x == y)++  let sgn (x: u8) = unsign (intrinsics.usignum8 (sign x))+  let abs (x: u8) = x++  let negate (x: t) = -x+  let max (x: t) (y: t) = unsign (intrinsics.umax8 (sign x, sign y))+  let min (x: t) (y: t) = unsign (intrinsics.umin8 (sign x, sign y))++  let highest = 255u8+  let lowest = 0u8++  let num_bits = 8+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc x = intrinsics.popc8 (sign x)+  let mul_hi a b = unsign (intrinsics.mul_hi8 (sign a, sign b))+  let mad_hi a b c = unsign (intrinsics.mad_hi8 (sign a, sign b, sign c))+  let clz x = intrinsics.clz8 (sign x)++  let iota (n: u8) = 0u8..1u8..<n+  let replicate 'v (n: u8) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module u16: (size with t = u16) = {+  type t = u16++  let sign (x: u16) = intrinsics.sign_i16 x+  let unsign (x: i16) = intrinsics.unsign_i16 x++  let (x: u16) + (y: u16) = unsign (intrinsics.add16 (sign x, sign y))+  let (x: u16) - (y: u16) = unsign (intrinsics.sub16 (sign x, sign y))+  let (x: u16) * (y: u16) = unsign (intrinsics.mul16 (sign x, sign y))+  let (x: u16) / (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+  let (x: u16) ** (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))+  let (x: u16) % (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))+  let (x: u16) // (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+  let (x: u16) %% (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))++  let (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x, sign y))+  let (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x, sign y))+  let (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x, sign y))+  let ! (x: u16) = unsign (intrinsics.complement16 (sign x))++  let (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x, sign y))+  let (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y))+  let (x: u16) >>> (y: u16) = unsign (intrinsics.lshr16 (sign x, sign y))++  let u8  (x: u8)  = unsign (i16.u8 x)+  let u16 (x: u16) = unsign (i16.u16 x)+  let u32 (x: u32) = unsign (i16.u32 x)+  let u64 (x: u64) = unsign (i16.u64 x)++  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i16 x)+  let i16 (x: i16) = unsign (intrinsics.zext_i16_i16 x)+  let i32 (x: i32) = unsign (intrinsics.zext_i32_i16 x)+  let i64 (x: i64) = unsign (intrinsics.zext_i64_i16 x)++  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i16 x)+  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i16 x)++  let bool x = unsign (intrinsics.btoi_bool_i16 x)++  let to_i32(x: u16) = intrinsics.zext_i16_i32 (sign x)+  let to_i64(x: u16) = intrinsics.zext_i16_i64 (sign x)++  let (x: u16) == (y: u16) = intrinsics.eq_i16 (sign x, sign y)+  let (x: u16) < (y: u16) = intrinsics.ult16 (sign x, sign y)+  let (x: u16) > (y: u16) = intrinsics.ult16 (sign y, sign x)+  let (x: u16) <= (y: u16) = intrinsics.ule16 (sign x, sign y)+  let (x: u16) >= (y: u16) = intrinsics.ule16 (sign y, sign x)+  let (x: u16) != (y: u16) = intrinsics.! (x == y)++  let sgn (x: u16) = unsign (intrinsics.usignum16 (sign x))+  let abs (x: u16) = x++  let negate (x: t) = -x+  let max (x: t) (y: t) = unsign (intrinsics.umax16 (sign x, sign y))+  let min (x: t) (y: t) = unsign (intrinsics.umin16 (sign x, sign y))++  let highest = 65535u16+  let lowest = 0u16++  let num_bits = 16+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc x = intrinsics.popc16 (sign x)+  let mul_hi a b = unsign (intrinsics.mul_hi16 (sign a, sign b))+  let mad_hi a b c = unsign (intrinsics.mad_hi16 (sign a, sign b, sign c))+  let clz x = intrinsics.clz16 (sign x)++  let iota (n: u16) = 0u16..1u16..<n+  let replicate 'v (n: u16) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module u32: (size with t = u32) = {+  type t = u32++  let sign (x: u32) = intrinsics.sign_i32 x+  let unsign (x: i32) = intrinsics.unsign_i32 x++  let (x: u32) + (y: u32) = unsign (intrinsics.add32 (sign x, sign y))+  let (x: u32) - (y: u32) = unsign (intrinsics.sub32 (sign x, sign y))+  let (x: u32) * (y: u32) = unsign (intrinsics.mul32 (sign x, sign y))+  let (x: u32) / (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+  let (x: u32) ** (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))+  let (x: u32) % (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))+  let (x: u32) // (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+  let (x: u32) %% (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))++  let (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x, sign y))+  let (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x, sign y))+  let (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x, sign y))+  let ! (x: u32) = unsign (intrinsics.complement32 (sign x))++  let (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x, sign y))+  let (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y))+  let (x: u32) >>> (y: u32) = unsign (intrinsics.lshr32 (sign x, sign y))++  let u8  (x: u8)  = unsign (i32.u8 x)+  let u16 (x: u16) = unsign (i32.u16 x)+  let u32 (x: u32) = unsign (i32.u32 x)+  let u64 (x: u64) = unsign (i32.u64 x)++  let i8  (x: i8)  = unsign (intrinsics.zext_i8_i32 x)+  let i16 (x: i16) = unsign (intrinsics.zext_i16_i32 x)+  let i32 (x: i32) = unsign (intrinsics.zext_i32_i32 x)+  let i64 (x: i64) = unsign (intrinsics.zext_i64_i32 x)++  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i32 x)+  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i32 x)++  let bool x = unsign (intrinsics.btoi_bool_i32 x)++  let to_i32(x: u32) = intrinsics.zext_i32_i32 (sign x)+  let to_i64(x: u32) = intrinsics.zext_i32_i64 (sign x)++  let (x: u32) == (y: u32) = intrinsics.eq_i32 (sign x, sign y)+  let (x: u32) < (y: u32) = intrinsics.ult32 (sign x, sign y)+  let (x: u32) > (y: u32) = intrinsics.ult32 (sign y, sign x)+  let (x: u32) <= (y: u32) = intrinsics.ule32 (sign x, sign y)+  let (x: u32) >= (y: u32) = intrinsics.ule32 (sign y, sign x)+  let (x: u32) != (y: u32) = intrinsics.! (x == y)++  let sgn (x: u32) = unsign (intrinsics.usignum32 (sign x))+  let abs (x: u32) = x++  let highest = 4294967295u32+  let lowest = highest + 1u32++  let negate (x: t) = -x+  let max (x: t) (y: t) = unsign (intrinsics.umax32 (sign x, sign y))+  let min (x: t) (y: t) = unsign (intrinsics.umin32 (sign x, sign y))++  let num_bits = 32+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc x = intrinsics.popc32 (sign x)+  let mul_hi a b = unsign (intrinsics.mul_hi32 (sign a, sign b))+  let mad_hi a b c = unsign (intrinsics.mad_hi32 (sign a, sign b, sign c))+  let clz x = intrinsics.clz32 (sign x)++  let iota (n: u32) = 0u32..1u32..<n+  let replicate 'v (n: u32) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module u64: (size with t = u64) = {+  type t = u64++  let sign (x: u64) = intrinsics.sign_i64 x+  let unsign (x: i64) = intrinsics.unsign_i64 x++  let (x: u64) + (y: u64) = unsign (intrinsics.add64 (sign x, sign y))+  let (x: u64) - (y: u64) = unsign (intrinsics.sub64 (sign x, sign y))+  let (x: u64) * (y: u64) = unsign (intrinsics.mul64 (sign x, sign y))+  let (x: u64) / (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+  let (x: u64) ** (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))+  let (x: u64) % (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))+  let (x: u64) // (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+  let (x: u64) %% (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))++  let (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x, sign y))+  let (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x, sign y))+  let (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x, sign y))+  let ! (x: u64) = unsign (intrinsics.complement64 (sign x))++  let (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x, sign y))+  let (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y))+  let (x: u64) >>> (y: u64) = unsign (intrinsics.lshr64 (sign x, sign y))++  let u8  (x: u8)  = unsign (i64.u8 x)+  let u16 (x: u16) = unsign (i64.u16 x)+  let u32 (x: u32) = unsign (i64.u32 x)+  let u64 (x: u64) = unsign (i64.u64 x)++  let i8 (x: i8)   = unsign (intrinsics.zext_i8_i64 x)+  let i16 (x: i16) = unsign (intrinsics.zext_i16_i64 x)+  let i32 (x: i32) = unsign (intrinsics.zext_i32_i64 x)+  let i64 (x: i64) = unsign (intrinsics.zext_i64_i64 x)++  let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i64 x)+  let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i64 x)++  let bool x = unsign (intrinsics.btoi_bool_i64 x)++  let to_i32(x: u64) = intrinsics.zext_i64_i32 (sign x)+  let to_i64(x: u64) = intrinsics.zext_i64_i64 (sign x)++  let (x: u64) == (y: u64) = intrinsics.eq_i64 (sign x, sign y)+  let (x: u64) < (y: u64) = intrinsics.ult64 (sign x, sign y)+  let (x: u64) > (y: u64) = intrinsics.ult64 (sign y, sign x)+  let (x: u64) <= (y: u64) = intrinsics.ule64 (sign x, sign y)+  let (x: u64) >= (y: u64) = intrinsics.ule64 (sign y, sign x)+  let (x: u64) != (y: u64) = intrinsics.! (x == y)++  let sgn (x: u64) = unsign (intrinsics.usignum64 (sign x))+  let abs (x: u64) = x++  let negate (x: t) = -x+  let max (x: t) (y: t) = unsign (intrinsics.umax64 (sign x, sign y))+  let min (x: t) (y: t) = unsign (intrinsics.umin64 (sign x, sign y))++  let highest = 18446744073709551615u64+  let lowest = highest + 1u64++  let num_bits = 64+  let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+  let set_bit (bit: i32) (x: t) (b: i32) =+    ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+  let popc x = intrinsics.popc64 (sign x)+  let mul_hi a b = unsign (intrinsics.mul_hi64 (sign a, sign b))+  let mad_hi a b c = unsign (intrinsics.mad_hi64 (sign a, sign b, sign c))+  let clz x = intrinsics.clz64 (sign x)++  let iota (n: u64) = 0u64..1u64..<n+  let replicate 'v (n: u64) (x: v) = map (const x) (iota n)++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module f64: (float with t = f64 with int_t = u64) = {+  type t = f64+  type int_t = u64++  module i64m = i64+  module u64m = u64++  let (x: f64) + (y: f64) = intrinsics.fadd64 (x, y)+  let (x: f64) - (y: f64) = intrinsics.fsub64 (x, y)+  let (x: f64) * (y: f64) = intrinsics.fmul64 (x, y)+  let (x: f64) / (y: f64) = intrinsics.fdiv64 (x, y)+  let (x: f64) % (y: f64) = intrinsics.fmod64 (x, y)+  let (x: f64) ** (y: f64) = intrinsics.fpow64 (x, y)++  let u8  (x: u8)  = intrinsics.uitofp_i8_f64  (i8.u8 x)+  let u16 (x: u16) = intrinsics.uitofp_i16_f64 (i16.u16 x)+  let u32 (x: u32) = intrinsics.uitofp_i32_f64 (i32.u32 x)+  let u64 (x: u64) = intrinsics.uitofp_i64_f64 (i64.u64 x)++  let i8 (x: i8) = intrinsics.sitofp_i8_f64 x+  let i16 (x: i16) = intrinsics.sitofp_i16_f64 x+  let i32 (x: i32) = intrinsics.sitofp_i32_f64 x+  let i64 (x: i64) = intrinsics.sitofp_i64_f64 x++  let f32 (x: f32) = intrinsics.fpconv_f32_f64 x+  let f64 (x: f64) = intrinsics.fpconv_f64_f64 x++  let bool (x: bool) = if x then 1f64 else 0f64++  let from_fraction (x: i32) (y: i32) = i32 x / i32 y+  let to_i32 (x: f64) = intrinsics.fptosi_f64_i32 x+  let to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x+  let to_f64 (x: f64) = x++  let (x: f64) == (y: f64) = intrinsics.eq_f64 (x, y)+  let (x: f64) < (y: f64) = intrinsics.lt64 (x, y)+  let (x: f64) > (y: f64) = intrinsics.lt64 (y, x)+  let (x: f64) <= (y: f64) = intrinsics.le64 (x, y)+  let (x: f64) >= (y: f64) = intrinsics.le64 (y, x)+  let (x: f64) != (y: f64) = intrinsics.! (x == y)++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.fmax64 (x, y)+  let min (x: t) (y: t) = intrinsics.fmin64 (x, y)++  let sgn (x: f64) = if      x < 0f64  then -1f64+                     else if x == 0f64 then  0f64+                     else                    1f64+  let abs (x: f64) = intrinsics.fabs64 x++  let sqrt (x: f64) = intrinsics.sqrt64 x++  let log (x: f64) = intrinsics.log64 x+  let log2 (x: f64) = intrinsics.log2_64 x+  let log10 (x: f64) = intrinsics.log10_64 x+  let exp (x: f64) = intrinsics.exp64 x+  let sin (x: f64) = intrinsics.sin64 x+  let cos (x: f64) = intrinsics.cos64 x+  let tan (x: f64) = intrinsics.tan64 x+  let acos (x: f64) = intrinsics.acos64 x+  let asin (x: f64) = intrinsics.asin64 x+  let atan (x: f64) = intrinsics.atan64 x+  let sinh (x: f64) = intrinsics.sinh64 x+  let cosh (x: f64) = intrinsics.cosh64 x+  let tanh (x: f64) = intrinsics.tanh64 x+  let acosh (x: f64) = intrinsics.acosh64 x+  let asinh (x: f64) = intrinsics.asinh64 x+  let atanh (x: f64) = intrinsics.atanh64 x+  let atan2 (x: f64) (y: f64) = intrinsics.atan2_64 (x, y)+  let gamma = intrinsics.gamma64+  let lgamma = intrinsics.lgamma64++  let lerp v0 v1 t = intrinsics.lerp64 (v0,v1,t)+  let fma a b c = intrinsics.fma64 (a,b,c)+  let mad a b c = intrinsics.mad64 (a,b,c)++  let ceil = intrinsics.ceil64+  let floor = intrinsics.floor64+  let trunc (x: f64) : f64 = i64 (i64m.f64 x)++  let round = intrinsics.round64++  let to_bits (x: f64): u64 = u64m.i64 (intrinsics.to_bits64 x)+  let from_bits (x: u64): f64 = intrinsics.from_bits64 (intrinsics.sign_i64 x)++  let num_bits = 64+  let get_bit (bit: i32) (x: t) = u64m.get_bit bit (to_bits x)+  let set_bit (bit: i32) (x: t) (b: i32) = from_bits (u64m.set_bit bit (to_bits x) b)++  let isinf (x: f64) = intrinsics.isinf64 x+  let isnan (x: f64) = intrinsics.isnan64 x++  let inf = 1f64 / 0f64+  let nan = 0f64 / 0f64++  let highest = inf+  let lowest = -inf++  let pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164062f64+  let e = 2.718281828459045235360287471352662497757247093699959574966967627724076630353f64++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}++module f32: (float with t = f32 with int_t = u32) = {+  type t = f32+  type int_t = u32++  module i32m = i32+  module u32m = u32+  module f64m = f64++  let (x: f32) + (y: f32) = intrinsics.fadd32 (x, y)+  let (x: f32) - (y: f32) = intrinsics.fsub32 (x, y)+  let (x: f32) * (y: f32) = intrinsics.fmul32 (x, y)+  let (x: f32) / (y: f32) = intrinsics.fdiv32 (x, y)+  let (x: f32) % (y: f32) = intrinsics.fmod32 (x, y)+  let (x: f32) ** (y: f32) = intrinsics.fpow32 (x, y)++  let u8  (x: u8)  = intrinsics.uitofp_i8_f32  (i8.u8 x)+  let u16 (x: u16) = intrinsics.uitofp_i16_f32 (i16.u16 x)+  let u32 (x: u32) = intrinsics.uitofp_i32_f32 (i32.u32 x)+  let u64 (x: u64) = intrinsics.uitofp_i64_f32 (i64.u64 x)++  let i8 (x: i8) = intrinsics.sitofp_i8_f32 x+  let i16 (x: i16) = intrinsics.sitofp_i16_f32 x+  let i32 (x: i32) = intrinsics.sitofp_i32_f32 x+  let i64 (x: i64) = intrinsics.sitofp_i64_f32 x++  let f32 (x: f32) = intrinsics.fpconv_f32_f32 x+  let f64 (x: f64) = intrinsics.fpconv_f64_f32 x++  let bool (x: bool) = if x then 1f32 else 0f32++  let from_fraction (x: i32) (y: i32) = i32 x / i32 y+  let to_i32 (x: f32) = intrinsics.fptosi_f32_i32 x+  let to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x+  let to_f64 (x: f32) = intrinsics.fpconv_f32_f64 x++  let (x: f32) == (y: f32) = intrinsics.eq_f32 (x, y)+  let (x: f32) < (y: f32) = intrinsics.lt32 (x, y)+  let (x: f32) > (y: f32) = intrinsics.lt32 (y, x)+  let (x: f32) <= (y: f32) = intrinsics.le32 (x, y)+  let (x: f32) >= (y: f32) = intrinsics.le32 (y, x)+  let (x: f32) != (y: f32) = intrinsics.! (x == y)++  let negate (x: t) = -x+  let max (x: t) (y: t) = intrinsics.fmax32 (x, y)+  let min (x: t) (y: t) = intrinsics.fmin32 (x, y)++  let sgn (x: f32) = if      x < 0f32  then -1f32+                     else if x == 0f32 then  0f32+                     else                    1f32+  let abs (x: f32) = intrinsics.fabs32 x++  let sqrt (x: f32) = intrinsics.sqrt32 x++  let log (x: f32) = intrinsics.log32 x+  let log2 (x: f32) = intrinsics.log2_32 x+  let log10 (x: f32) = intrinsics.log10_32 x+  let exp (x: f32) = intrinsics.exp32 x+  let sin (x: f32) = intrinsics.sin32 x+  let cos (x: f32) = intrinsics.cos32 x+  let tan (x: f32) = intrinsics.tan32 x+  let acos (x: f32) = intrinsics.acos32 x+  let asin (x: f32) = intrinsics.asin32 x+  let atan (x: f32) = intrinsics.atan32 x+  let sinh (x: f32) = intrinsics.sinh32 x+  let cosh (x: f32) = intrinsics.cosh32 x+  let tanh (x: f32) = intrinsics.tanh32 x+  let acosh (x: f32) = intrinsics.acosh32 x+  let asinh (x: f32) = intrinsics.asinh32 x+  let atanh (x: f32) = intrinsics.atanh32 x+  let atan2 (x: f32) (y: f32) = intrinsics.atan2_32 (x, y)+  let gamma = intrinsics.gamma32+  let lgamma = intrinsics.lgamma32++  let lerp v0 v1 t = intrinsics.lerp32 (v0,v1,t)+  let fma a b c = intrinsics.fma32 (a,b,c)+  let mad a b c = intrinsics.mad32 (a,b,c)++  let ceil = intrinsics.ceil32+  let floor = intrinsics.floor32+  let trunc (x: f32) : f32 = i32 (i32m.f32 x)++  let round = intrinsics.round32++  let to_bits (x: f32): u32 = u32m.i32 (intrinsics.to_bits32 x)+  let from_bits (x: u32): f32 = intrinsics.from_bits32 (intrinsics.sign_i32 x)++  let num_bits = 32+  let get_bit (bit: i32) (x: t) = u32m.get_bit bit (to_bits x)+  let set_bit (bit: i32) (x: t) (b: i32) = from_bits (u32m.set_bit bit (to_bits x) b)++  let isinf (x: f32) = intrinsics.isinf32 x+  let isnan (x: f32) = intrinsics.isnan32 x++  let inf = 1f32 / 0f32+  let nan = 0f32 / 0f32++  let highest = inf+  let lowest = -inf++  let pi = f64 f64m.pi+  let e = f64 f64m.e++  let sum = reduce (+) (i32 0)+  let product = reduce (*) (i32 1)+  let maximum = reduce max lowest+  let minimum = reduce min highest+}
+ prelude/prelude.fut view
@@ -0,0 +1,34 @@+-- | The default prelude that is implicitly available in all Futhark+-- files.++open import "soacs"+open import "array"+open import "math"+open import "functional"++-- | Create single-precision float from integer.+let r32 (x: i32): f32 = f32.i32 x+-- | Create integer from single-precision float.+let t32 (x: f32): i32 = i32.f32 x++-- | Create double-precision float from integer.+let r64 (x: i32): f64 = f64.i32 x+-- | Create integer from double-precision float.+let t64 (x: f64): i32 = i32.f64 x++-- | Semantically just identity, but serves as an optimisation+-- inhibitor.  The compiler will treat this function as a black box.+-- You can use this to work around optimisation deficiencies (or+-- bugs), although it should hopefully rarely be necessary.+let opaque 't (x: t): t =+  intrinsics.opaque x++-- | Semantically just identity, but when run in the interpreter, the+-- argument value will be printed.+let trace 't (x: t): t =+  intrinsics.trace x++-- | Semantically just identity, but acts as a break point in+-- `futhark repl`.+let break 't (x: t): t =+  intrinsics.break x
+ prelude/soacs.fut view
@@ -0,0 +1,256 @@+-- | Various Second-Order Array Combinators that are operationally+-- parallel in a way that can be exploited by the compiler.+--+-- The functions here are all recognised specially by the compiler (or+-- built on those that are).  The asymptotic [work and+-- span](https://en.wikipedia.org/wiki/Analysis_of_parallel_algorithms)+-- is provided for each function, but note that this easily hides very+-- substantial constant factors.  For example, `scan`@term is *much*+-- slower than `reduce`@term, although they have the same asymptotic+-- complexity.+--+-- *Reminder on terminology*: A function `op` is said to be+-- *associative* if+--+--     (x `op` y) `op` z == x `op` (y `op` z)+--+-- for all `x`, `y`, `z`.  Similarly, it is *commutative* if+--+--     x `op` y == y `op` x+--+-- The value `o` is a *neutral element* if+--+--     x `op` o == o `op` x == x+--+-- for any `x`.++-- Implementation note: many of these definitions contain dynamically+-- checked size casts.  These will be removed by the compiler, but are+-- necessary for the type checker, as the 'intrinsics' functions are+-- not size-dependently typed.++import "zip"++-- | Apply the given function to each element of an array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =+  intrinsics.map (f, as) :> *[n]x++-- | Apply the given function to each element of a single array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map1 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =+  map f as++-- | As `map1`@term, but with one more array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map2 'a 'b [n] 'x (f: a -> b -> x) (as: [n]a) (bs: [n]b): *[n]x =+  map (\(a, b) -> f a b) (zip2 as bs)++-- | As `map2`@term, but with one more array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map3 'a 'b 'c [n] 'x (f: a -> b -> c -> x) (as: [n]a) (bs: [n]b) (cs: [n]c): *[n]x =+  map (\(a, b, c) -> f a b c) (zip3 as bs cs)++-- | As `map3`@term, but with one more array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map4 'a 'b 'c 'd [n] 'x (f: a -> b -> c -> d -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): *[n]x =+  map (\(a, b, c, d) -> f a b c d) (zip4 as bs cs ds)++-- | As `map4`@term, but with one more array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map5 'a 'b 'c 'd 'e [n] 'x (f: a -> b -> c -> d -> e -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): *[n]x =+  map (\(a, b, c, d, e) -> f a b c d e) (zip5 as bs cs ds es)++-- | Reduce the array `as` with `op`, with `ne` as the neutral+-- element for `op`.  The function `op` must be associative.  If+-- it is not, the return value is unspecified.  If the value returned+-- by the operator is an array, it must have the exact same size as+-- the neutral element, and that must again have the same size as the+-- elements of the input array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let reduce [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): a =+  intrinsics.reduce (op, ne, as)++-- | As `reduce`, but the operator must also be commutative.  This is+-- potentially faster than `reduce`.  For simple built-in operators,+-- like addition, the compiler already knows that the operator is+-- commutative, so plain `reduce`@term will work just as well.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let reduce_comm [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): a =+  intrinsics.reduce_comm (op, ne, as)++-- | `reduce_by_index dest f ne is as` returns `dest`, but with each+-- element given by the indices of `is` updated by applying `f` to the+-- current value in `dest` and the corresponding value in `as`.  The+-- `ne` value must be a neutral element for `op`.  If `is` has+-- duplicates, `f` may be applied multiple times, and hence must be+-- associative and commutative.  Out-of-bounds indices in `is` are+-- ignored.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(n)* in the worst case (all updates to same position),+-- but *O(1)* in the best case.+--+-- In practice, the *O(n)* behaviour only occurs if *m* is also very+-- large.+let reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i32) (as : [n]a) : *[m]a =+  intrinsics.hist (1, dest, f, ne, is, as) :> *[m]a++-- | Inclusive prefix scan.  Has the same caveats with respect to+-- associativity as `reduce`.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let scan [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): *[n]a =+  intrinsics.scan (op, ne, as) :> *[n]a++-- | Remove all those elements of `as` that do not satisfy the+-- predicate `p`.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let filter [n] 'a (p: a -> bool) (as: [n]a): *[]a =+  let (as', is) = intrinsics.partition (1, \x -> if p x then 0 else 1, as)+  in as'[:is[0]]++-- | Split an array into those elements that satisfy the given+-- predicate, and those that do not.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let partition [n] 'a (p: a -> bool) (as: [n]a): ([]a, []a) =+  let p' x = if p x then 0 else 1+  let (as', is) = intrinsics.partition (2, p', as)+  in (as'[0:is[0]], as'[is[0]:n])++-- | Split an array by two predicates, producing three arrays.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a): ([]a, []a, []a) =+  let p' x = if p1 x then 0 else if p2 x then 1 else 2+  let (as', is) = intrinsics.partition (3, p', as)+  in (as'[0:is[0]], as'[is[0]:is[0]+is[1]], as'[is[0]+is[1]:n])++-- | `reduce_stream op f as` splits `as` into chunks, applies `f` to each+-- of these in parallel, and uses `op` (which must be associative) to+-- combine the per-chunk results into a final result.  The `i32`+-- passed to `f` is the size of the chunk.  This SOAC is useful when+-- `f` can be given a particularly work-efficient sequential+-- implementation.  Operationally, we can imagine that `as` is divided+-- among as many threads as necessary to saturate the machine, with+-- each thread operating sequentially.+--+-- A chunk may be empty, and `f 0 []` must produce the neutral element for+-- `op`.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let reduce_stream [n] 'a 'b (op: b -> b -> b) (f: (k: i32) -> [k]a -> b) (as: [n]a): b =+  intrinsics.reduce_stream (op, f, as)++-- | As `reduce_stream`@term, but the chunks do not necessarily+-- correspond to subsequences of the original array (they may be+-- interleaved).+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let reduce_stream_per [n] 'a 'b (op: b -> b -> b) (f: (k: i32) -> [k]a -> b) (as: [n]a): b =+  intrinsics.reduce_stream_per (op, f, as)++-- | Similar to `reduce_stream`@term, except that each chunk must produce+-- an array *of the same size*.  The per-chunk results are+-- concatenated.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map_stream [n] 'a 'b (f: (k: i32) -> [k]a -> [k]b) (as: [n]a): *[n]b =+  intrinsics.map_stream (f, as) :> *[n]b++-- | Similar to `map_stream`@term, but the chunks do not necessarily+-- correspond to subsequences of the original array (they may be+-- interleaved).+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let map_stream_per [n] 'a 'b (f: (k: i32) -> [k]a -> [k]b) (as: [n]a): *[n]b =+  intrinsics.map_stream_per (f, as) :> *[n]b++-- | Return `true` if the given function returns `true` for all+-- elements in the array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let all [n] 'a (f: a -> bool) (as: [n]a): bool =+  reduce (&&) true (map f as)++-- | Return `true` if the given function returns `true` for any+-- elements in the array.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(log(n))*+let any [n] 'a (f: a -> bool) (as: [n]a): bool =+  reduce (||) false (map f as)++-- | The `scatter as is vs` expression calculates the equivalent of+-- this imperative code:+--+-- ```+-- for index in 0..length is-1:+--   i = is[index]+--   v = vs[index]+--   as[i] = v+-- ```+--+-- The `is` and `vs` arrays must have the same outer size.  `scatter`+-- acts in-place and consumes the `as` array, returning a new array+-- that has the same type and elements as `as`, except for the indices+-- in `is`.  If `is` contains duplicates (i.e. several writes are+-- performed to the same location), the result is unspecified.  It is+-- not guaranteed that one of the duplicate writes will complete+-- atomically - they may be interleaved.  See `reduce_by_index`@term+-- for a function that can handle this case deterministically.+--+-- This is technically not a second-order operation, but it is defined+-- here because it is closely related to the SOACs.+--+-- **Work:** *O(n)*+--+-- **Span:** *O(1)*+let scatter 't [m] [n] (dest: *[m]t) (is: [n]i32) (vs: [n]t): *[m]t =+  intrinsics.scatter (dest, is, vs) :> *[m]t
+ prelude/zip.fut view
@@ -0,0 +1,58 @@+-- | Transforming arrays of tuples into tuples of arrays and back+-- again.  These are generally very cheap operations, as the internal+-- compiler representation is always tuples of arrays.++-- The main reason this module exists is that we need it to define+-- SOACs like `map2`.++-- We need a map to define some of the zip variants, but this file is+-- depended upon by soacs.fut.  So we just define a quick-and-dirty+-- internal one here that uses the intrinsic version.+local let internal_map 'a [n] 'x (f: a -> x) (as: [n]a): [n]x =+  intrinsics.map (f, as) :> [n]x++-- | Construct an array of pairs from two arrays.+let zip [n] 'a 'b (as: [n]a) (bs: [n]b): [n](a,b) =+  intrinsics.zip (as, bs) :> [n](a,b)++-- | Construct an array of pairs from two arrays.+let zip2 [n] 'a 'b (as: [n]a) (bs: [n]b): [n](a,b) =+  zip as bs :> [n](a,b)++-- | As `zip2`@term, but with one more array.+let zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c): [n](a,b,c) =+  internal_map (\(a,(b,c)) -> (a,b,c)) (zip as (zip2 bs cs))++-- | As `zip3`@term, but with one more array.+let zip4 [n] 'a 'b 'c 'd (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): [n](a,b,c,d) =+  internal_map (\(a,(b,c,d)) -> (a,b,c,d)) (zip as (zip3 bs cs ds))++-- | As `zip4`@term, but with one more array.+let zip5 [n] 'a 'b 'c 'd 'e (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): [n](a,b,c,d,e) =+  internal_map (\(a,(b,c,d,e)) -> (a,b,c,d,e)) (zip as (zip4 bs cs ds es))++-- | Turn an array of pairs into two arrays.+let unzip [n] 'a 'b (xs: [n](a,b)): ([n]a, [n]b) =+  intrinsics.unzip xs :> ([n]a, [n]b)++-- | Turn an array of pairs into two arrays.+let unzip2 [n] 'a 'b (xs: [n](a,b)): ([n]a, [n]b) =+  unzip xs++-- | As `unzip2`@term, but with one more array.+let unzip3 [n] 'a 'b 'c (xs: [n](a,b,c)): ([n]a, [n]b, [n]c) =+  let (as, bcs) = unzip (internal_map (\(a,b,c) -> (a,(b,c))) xs)+  let (bs, cs) = unzip bcs+  in (as, bs, cs)++-- | As `unzip3`@term, but with one more array.+let unzip4 [n] 'a 'b 'c 'd (xs: [n](a,b,c,d)): ([n]a, [n]b, [n]c, [n]d) =+  let (as, bs, cds) = unzip3 (internal_map (\(a,b,c,d) -> (a,b,(c,d))) xs)+  let (cs, ds) = unzip cds+  in (as, bs, cs, ds)++-- | As `unzip4`@term, but with one more array.+let unzip5 [n] 'a 'b 'c 'd 'e (xs: [n](a,b,c,d,e)): ([n]a, [n]b, [n]c, [n]d, [n]e) =+  let (as, bs, cs, des) = unzip4 (internal_map (\(a,b,c,d,e) -> (a,b,c,(d,e))) xs)+  let (ds, es) = unzip des+  in (as, bs, cs, ds, es)
rts/c/cuda.h view
@@ -67,7 +67,7 @@   cfg->load_ptx_from = NULL;    cfg->default_block_size = 256;-  cfg->default_grid_size = 128;+  cfg->default_grid_size = 256;   cfg->default_tile_size = 32;   cfg->default_threshold = 32*1024;
rts/c/opencl.h view
@@ -4,13 +4,13 @@ #define OPENCL_SUCCEED_NONFATAL(e) opencl_succeed_nonfatal(e, #e, __FILE__, __LINE__) // Take care not to override an existing error. #define OPENCL_SUCCEED_OR_RETURN(e) {             \-    char *error = OPENCL_SUCCEED_NONFATAL(e);     \-    if (error) {                                  \+    char *serror = OPENCL_SUCCEED_NONFATAL(e);    \+    if (serror) {                                 \       if (!ctx->error) {                          \-        ctx->error = error;                       \+        ctx->error = serror;                      \         return bad;                               \       } else {                                    \-        free(error);                              \+        free(serror);                             \       }                                           \     }                                             \   }
rts/csharp/scalar.cs view
@@ -281,6 +281,12 @@ private static double futhark_acos64(double x){return Math.Acos(x);} private static double futhark_asin64(double x){return Math.Asin(x);} private static double futhark_atan64(double x){return Math.Atan(x);}+private static double futhark_cosh64(double x){return Math.Cosh(x);}+private static double futhark_sinh64(double x){return Math.Sinh(x);}+private static double futhark_tanh64(double x){return Math.Tanh(x);}+private static double futhark_acosh64(double x){return Math.Acosh(x);}+private static double futhark_asinh64(double x){return Math.Asinh(x);}+private static double futhark_atanh64(double x){return Math.Atanh(x);} private static double futhark_atan2_64(double x, double y){return Math.Atan2(x, y);} private static double futhark_gamma64(double x){throw new NotImplementedException();} private static double futhark_lgamma64(double x){throw new NotImplementedException();}@@ -300,6 +306,12 @@ private static float futhark_acos32(float x){return (float) Math.Acos(x);} private static float futhark_asin32(float x){return (float) Math.Asin(x);} private static float futhark_atan32(float x){return (float) Math.Atan(x);}+private static float futhark_cosh32(float x){return (float) Math.Cosh(x);}+private static float futhark_sinh32(float x){return (float) Math.Sinh(x);}+private static float futhark_tanh32(float x){return (float) Math.Tanh(x);}+private static float futhark_acosh32(float x){return (float) Math.Acosh(x);}+private static float futhark_asinh32(float x){return (float) Math.Asinh(x);}+private static float futhark_atanh32(float x){return (float) Math.Atanh(x);} private static float futhark_atan2_32(float x, float y){return (float) Math.Atan2(x, y);} private static float futhark_gamma32(float x){throw new NotImplementedException();} private static float futhark_lgamma32(float x){throw new NotImplementedException();}@@ -318,6 +330,13 @@ private static float futhark_lerp32(float v0, float v1, float t){return v0 + (v1-v0)*t;} private static double futhark_lerp64(double v0, double v1, double t){return v0 + (v1-v0)*t;} +private static float futhark_fma32(float a, float b, float c){return a*b+c;}+private static double futhark_fma64(double a, double b, double c){return a*b+c;}++private static float futhark_mad32(float a, float b, float c){return a*b+c;}+private static double futhark_mad64(double a, double b, double c){return a*b+c;}++ int futhark_popc8 (sbyte x) {   int c = 0;   for (; x != 0; ++c) {@@ -392,6 +411,57 @@         x <<= 1;     }     return n;+}++sbyte futhark_mul_hi8(sbyte a, sbyte b) {+    ushort aa = (ushort)(byte)a;+    ushort bb = (ushort)(byte)b;+    return (sbyte)((aa * bb) >> 8);+}++short futhark_mul_hi16(short a, short b) {+    uint aa = (uint)(ushort)a;+    uint bb = (uint)(ushort)b;+    return (short)((aa * bb) >> 16);+}++int futhark_mul_hi32(int a, int b) {+    ulong aa = (ulong)(uint)a;+    ulong bb = (ulong)(uint)b;+    return (int)((aa * bb) >> 32);+}++// By Ben Voigt at+// https://stackoverflow.com/questions/29722093/computing-the-high-bits-of-a-multiplication-in-c-sharp+long futhark_mul_hi64(long xx, long yy) {+    ulong x = (ulong)xx;+    ulong y = (ulong)yy;+    ulong accum = ((ulong)(uint)x) * ((ulong)(uint)y);+    accum >>= 32;+    ulong term1 = (x >> 32) * ((ulong)(uint)y);+    ulong term2 = (y >> 32) * ((ulong)(uint)x);+    accum += (uint)term1;+    accum += (uint)term2;+    accum >>= 32;+    accum += (term1 >> 32) + (term2 >> 32);+    accum += (x >> 32) * (y >> 32);+    return (long)accum;+}++sbyte futhark_mad_hi8(sbyte a, sbyte b, sbyte c) {+    return (sbyte)(futhark_mul_hi8(a,b) + c);+}++short futhark_mad_hi16(short a, short b, short c) {+    return (short)(futhark_mul_hi16(a,b) + c);+}++int futhark_mad_hi32(int a, int b, int c) {+    return futhark_mul_hi32(a,b) + c;+}++long futhark_mad_hi64(long a, long b, long c) {+    return futhark_mul_hi64(a,b) + c; }  private static bool llt (bool x, bool y){return (!x && y);}
rts/python/opencl.py view
@@ -112,6 +112,12 @@     self.max_local_memory = int(self.device.local_mem_size)     self.free_list = {} +    self.global_failure = self.pool.allocate(np.int32().itemsize)+    cl.enqueue_fill_buffer(self.queue, self.global_failure, np.int32(-1), 0, np.int32().itemsize)+    self.global_failure_args = self.pool.allocate(np.int32().itemsize *+                                                  (self.global_failure_args_max+1))+    self.failure_is_an_option = np.int32(0)+     if 'default_group_size' in sizes:         default_group_size = sizes['default_group_size']         del sizes['default_group_size']@@ -201,3 +207,12 @@  def opencl_free_all(self):     self.pool.free_held()++def sync(self):+    failure = np.empty(1, dtype=np.int32)+    cl.enqueue_copy(self.queue, failure, self.global_failure, is_blocking=True)+    self.failure_is_an_option = np.int32(0)+    if failure[0] >= 0:+        failure_args = np.empty(self.global_failure_args_max+1, dtype=np.int32)+        cl.enqueue_copy(self.queue, failure_args, self.global_failure_args, is_blocking=True)+        raise Exception(self.failure_msgs[failure[0]].format(*failure_args))
rts/python/scalar.py view
@@ -280,6 +280,39 @@ def fpconv_f64_f32(x):   return np.float32(x) +def futhark_mul_hi8(a, b):+  a = np.uint64(np.uint8(a))+  b = np.uint64(np.uint8(b))+  return np.int8((a*b) >> np.uint64(8))++def futhark_mul_hi16(a, b):+  a = np.uint64(np.uint16(a))+  b = np.uint64(np.uint16(b))+  return np.int16((a*b) >> np.uint64(16))++def futhark_mul_hi32(a, b):+  a = np.uint64(np.uint32(a))+  b = np.uint64(np.uint32(b))+  return np.int32((a*b) >> np.uint64(32))++# This one is done with arbitrary-precision integers.+def futhark_mul_hi64(a, b):+  a = int(np.uint64(a))+  b = int(np.uint64(b))+  return np.int64(np.uint64(a*b >> 64))++def futhark_mad_hi8(a, b, c):+  return futhark_mul_hi8(a,b) + c++def futhark_mad_hi16(a, b, c):+  return futhark_mul_hi16(a,b) + c++def futhark_mad_hi32(a, b, c):+  return futhark_mul_hi32(a,b) + c++def futhark_mad_hi64(a, b, c):+  return futhark_mul_hi64(a,b) + c+ def futhark_log64(x):   return np.float64(np.log(x)) @@ -313,6 +346,24 @@ def futhark_atan64(x):   return np.arctan(x) +def futhark_cosh64(x):+  return np.cosh(x)++def futhark_sinh64(x):+  return np.sinh(x)++def futhark_tanh64(x):+  return np.tanh(x)++def futhark_acosh64(x):+  return np.arccosh(x)++def futhark_asinh64(x):+  return np.arcsinh(x)++def futhark_atanh64(x):+  return np.arctanh(x)+ def futhark_atan2_64(x, y):   return np.arctan2(x, y) @@ -378,6 +429,24 @@ def futhark_atan32(x):   return np.arctan(x) +def futhark_cosh32(x):+  return np.cosh(x)++def futhark_sinh32(x):+  return np.sinh(x)++def futhark_tanh32(x):+  return np.tanh(x)++def futhark_acosh32(x):+  return np.arccosh(x)++def futhark_asinh32(x):+  return np.arcsinh(x)++def futhark_atanh32(x):+  return np.arctanh(x)+ def futhark_atan2_32(x, y):   return np.arctan2(x, y) @@ -415,5 +484,17 @@  def futhark_lerp64(v0, v1, t):   return v0 + (v1-v0)*t++def futhark_mad32(a, b, c):+  return a * b + c++def futhark_mad64(a, b, c):+  return a * b + c++def futhark_fma32(a, b, c):+  return a * b + c++def futhark_fma64(a, b, c):+  return a * b + c  # End of scalar.py.
src/Futhark/Analysis/Alias.hs view
@@ -28,7 +28,7 @@ -- | Perform alias analysis on a Futhark program. aliasAnalysis :: (Attributes lore, CanBeAliased (Op lore)) =>                  Prog lore -> Prog (Aliases lore)-aliasAnalysis = Prog . map analyseFun . progFunctions+aliasAnalysis = Prog . map analyseFun . progFuns  analyseFun :: (Attributes lore, CanBeAliased (Op lore)) =>               FunDef lore -> FunDef (Aliases lore)
src/Futhark/Analysis/CallGraph.hs view
@@ -17,7 +17,7 @@ type FunctionTable = M.Map Name (FunDef SOACS)  buildFunctionTable :: Prog SOACS -> FunctionTable-buildFunctionTable = foldl expand M.empty . progFunctions+buildFunctionTable = foldl expand M.empty . progFuns   where expand ftab f = M.insert (funDefName f) f ftab  -- | The call graph is just a mapping from a function name, i.e., the@@ -29,7 +29,7 @@ buildCallGraph :: Prog SOACS -> CallGraph buildCallGraph prog = foldl' (buildCGfun ftable) M.empty entry_points   where entry_points = map funDefName $ filter (isJust . funDefEntryPoint) $-                       progFunctions prog+                       progFuns prog         ftable = buildFunctionTable prog  -- | @buildCallGraph ftable cg fname@ updates @cg@ with the
src/Futhark/Analysis/HORepresentation/SOAC.hs view
@@ -431,7 +431,7 @@                   | t <- drop (length nes) (lambdaReturnType lam) ]   in  accrtps ++ arrtps typeOf (Scatter _w lam _ivs dests) =-  zipWith arrayOfRow (snd $ splitAt (n `div` 2) lam_ts) aws+  zipWith arrayOfRow (drop (n `div` 2) lam_ts) aws   where lam_ts = lambdaReturnType lam         n = length lam_ts         (aws, _, _) = unzip3 dests@@ -634,9 +634,7 @@     where mkMapPlusAccLam :: (MonadFreshNames m, Bindable lore)                           => [SubExp] -> Lambda lore -> m (Lambda lore)           mkMapPlusAccLam accs plus = do-            let lampars = lambdaParams plus-                (accpars, rempars) = (  take (length accs) lampars,-                                        drop (length accs) lampars  )+            let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus                 parbnds = zipWith (\ par se -> mkLet [] [paramIdent par]                                                         (BasicOp $ SubExp se)                                   ) accpars accs
src/Futhark/Analysis/Metrics.hs view
@@ -73,7 +73,7 @@         addWhat' (ctx, k) = (what : ctx, k)  progMetrics :: OpMetrics (Op lore) => Prog lore -> AstMetrics-progMetrics = actualMetrics . execWriter . runMetricsM . mapM_ funDefMetrics . progFunctions+progMetrics = actualMetrics . execWriter . runMetricsM . mapM_ funDefMetrics . progFuns  funDefMetrics :: OpMetrics (Op lore) => FunDef lore -> MetricsM () funDefMetrics = bodyMetrics . funDefBody
src/Futhark/Analysis/PrimExp.hs view
@@ -7,6 +7,7 @@   , primExpType   , primExpSizeAtLeast   , coerceIntPrimExp+  , leafExpTypes   , true   , false   , constFoldPrimExp@@ -18,6 +19,7 @@ import           Control.Monad import           Data.Traversable import qualified Data.Map as M+import qualified Data.Set as S  import           Futhark.Representation.AST.Attributes.Names import           Futhark.Representation.Primitive@@ -345,3 +347,15 @@   ppr (ConvOpExp op x)  = ppr op <+> parens (ppr x)   ppr (UnOpExp op x)    = ppr op <+> parens (ppr x)   ppr (FunExp h args _) = text h <+> parens (commasep $ map ppr args)++leafExpTypes :: Ord a => PrimExp a -> S.Set (a, PrimType)+leafExpTypes (LeafExp x ptp) = S.singleton (x, ptp)+leafExpTypes (ValueExp _) = S.empty+leafExpTypes (UnOpExp _ e) = leafExpTypes e+leafExpTypes (ConvOpExp _ e) = leafExpTypes e+leafExpTypes (BinOpExp _ e1 e2) =+  S.union (leafExpTypes e1) (leafExpTypes e2)+leafExpTypes (CmpOpExp _ e1 e2) =+  S.union (leafExpTypes e1) (leafExpTypes e2)+leafExpTypes (FunExp _ pes _) =+  S.unions $ map leafExpTypes pes
src/Futhark/Analysis/PrimExp/Convert.hs view
@@ -4,6 +4,7 @@   (     primExpToExp   , primExpFromExp+  , primExpToSubExp   , primExpFromSubExp   , primExpFromSubExpM   , replaceInPrimExp@@ -76,10 +77,9 @@       FunExp (nameToString fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t primExpFromExp _ _ = fail "Not a PrimExp" -primExpFromSubExpM :: Fail.MonadFail m =>-                      (VName -> m (PrimExp v)) -> SubExp -> m (PrimExp v)+primExpFromSubExpM :: Applicative m => (VName -> m (PrimExp v)) -> SubExp -> m (PrimExp v) primExpFromSubExpM f (Var v) = f v-primExpFromSubExpM _ (Constant v) = return $ ValueExp v+primExpFromSubExpM _ (Constant v) = pure $ ValueExp v  -- | Convert 'SubExp's of a given type. primExpFromSubExp :: PrimType -> SubExp -> PrimExp VName
+ src/Futhark/Analysis/PrimExp/Generalize.hs view
@@ -0,0 +1,70 @@+module Futhark.Analysis.PrimExp.Generalize+  (+    leastGeneralGeneralization+  ) where++import           Control.Monad+import           Data.List (elemIndex)+++import           Futhark.Analysis.PrimExp+import           Futhark.Representation.AST.Syntax.Core (Ext(..))++-- | Generalization (anti-unification)+-- We assume that the two expressions have the same type.+leastGeneralGeneralization :: (Eq v) => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v ->+                              Maybe (PrimExp (Ext v), [(PrimExp v, PrimExp v)])+leastGeneralGeneralization m exp1@(LeafExp v1 t1) exp2@(LeafExp v2 _) =+  if v1 == v2 then+    Just (LeafExp (Free v1) t1, m)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(ValueExp v1) exp2@(ValueExp v2) =+  if v1 == v2 then+    Just (ValueExp v1, m)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(BinOpExp op1 e11 e12) exp2@(BinOpExp op2 e21 e22) =+  if op1 == op2 then do+    (e1, m1) <- leastGeneralGeneralization m e11 e21+    (e2, m2) <- leastGeneralGeneralization m1 e12 e22+    return (BinOpExp op1 e1 e2, m2)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(CmpOpExp op1 e11 e12) exp2@(CmpOpExp op2 e21 e22) =+  if op1 == op2 then do+    (e1, m1) <- leastGeneralGeneralization m e11 e21+    (e2, m2) <- leastGeneralGeneralization m1 e12 e22+    return (CmpOpExp op1 e1 e2, m2)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(UnOpExp op1 e1) exp2@(UnOpExp op2 e2) =+  if op1 == op2 then do+    (e, m1) <- leastGeneralGeneralization m e1 e2+    return (UnOpExp op1 e, m1)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(ConvOpExp op1 e1) exp2@(ConvOpExp op2 e2) =+  if op1 == op2 then do+    (e, m1) <- leastGeneralGeneralization m e1 e2+    return (ConvOpExp op1 e, m1)+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1@(FunExp s1 args1 t1) exp2@(FunExp s2 args2 _) =+  if s1 == s2 && length args1 == length args2 then do+    (args, m') <- foldM (\(arg_acc, m_acc) (a1, a2) -> do+                            (a, m'') <- leastGeneralGeneralization m_acc a1 a2+                            return (a : arg_acc, m'')+                        ) ([], m) (zip args1 args2)+    return (FunExp s1 (reverse args) t1, m')+  else+    Just $ generalize m exp1 exp2+leastGeneralGeneralization m exp1 exp2 =+  Just $ generalize m exp1 exp2++generalize :: Eq v => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v -> (PrimExp (Ext v), [(PrimExp v, PrimExp v)])+generalize m exp1 exp2 =+  let t = primExpType exp1+  in case elemIndex (exp1, exp2) m of+       Just i -> (LeafExp (Ext i) t, m)+       Nothing -> (LeafExp (Ext $ length m) t, m ++ [(exp1, exp2)])
src/Futhark/Analysis/Range.hs view
@@ -25,7 +25,7 @@ -- program with embedded range annotations. rangeAnalysis :: (Attributes lore, CanBeRanged (Op lore)) =>                  Prog lore -> Prog (Ranges lore)-rangeAnalysis = Prog . map analyseFun . progFunctions+rangeAnalysis = Prog . map analyseFun . progFuns  -- Implementation
src/Futhark/Analysis/Rephrase.hs view
@@ -30,7 +30,7 @@               }  rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to)-rephraseProg rephraser = fmap Prog . mapM (rephraseFunDef rephraser) . progFunctions+rephraseProg rephraser = fmap Prog . mapM (rephraseFunDef rephraser) . progFuns  rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) rephraseFunDef rephraser fundec = do
src/Futhark/Analysis/SymbolTable.hs view
@@ -411,7 +411,7 @@ enclosingLoopVars :: [VName] -> SymbolTable lore -> [VName] enclosingLoopVars free vtable =   map fst $-  sortBy (flip (comparing (bindingDepth . snd))) $+  sortOn (Down . bindingDepth . snd) $   filter (loopVariable . snd) $ mapMaybe fetch free   where fetch name = do e <- lookup name vtable                         return (name, e)
src/Futhark/Analysis/Usage.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} module Futhark.Analysis.Usage ( usageInStm ) where -import Data.Foldable- import Futhark.Representation.AST import Futhark.Representation.AST.Attributes.Aliases import qualified Futhark.Analysis.UsageTable as UT@@ -30,7 +28,7 @@             namesToList $ subExpAliases se           | (v,se) <- merge, unique $ paramDeclType v ] usageInExp (If _ tbranch fbranch _) =-  fold $ map UT.consumedUsage $ namesToList $+  foldMap UT.consumedUsage $ namesToList $   consumedInBody tbranch <> consumedInBody fbranch usageInExp (BasicOp (Update src _ _)) =   UT.consumedUsage src
src/Futhark/Bench.hs view
@@ -215,6 +215,7 @@   CompileOptions   { compFuthark :: String   , compBackend :: String+  , compOptions :: [String]   }  progNotFound :: String -> String@@ -239,7 +240,9 @@      Right () -> do       (futcode, _, futerr) <- liftIO $ readProcessWithExitCode futhark-                              [compBackend opts, program, "-o", binaryName program] ""+                              ([compBackend opts, program, "-o", binaryName program] <>+                               compOptions opts)+                              ""        case futcode of         ExitSuccess     -> return $ Right ()
src/Futhark/Binder.hs view
@@ -31,7 +31,6 @@ import Control.Monad.Reader import Control.Monad.Error.Class import qualified Data.Map.Strict as M-import qualified Control.Monad.Fail as Fail  import Futhark.Binder.Class import Futhark.Representation.AST@@ -62,9 +61,6 @@ instance MonadTrans (BinderT lore) where   lift = BinderT . lift -instance Monad m => Fail.MonadFail (BinderT lore m) where-  fail = error . ("BinderT.fail: "++)- type Binder lore = BinderT lore (State VNameSource)  instance MonadFreshNames m => MonadFreshNames (BinderT lore m) where@@ -76,7 +72,7 @@   lookupType name = do     t <- BinderT $ gets $ M.lookup name . snd     case t of-      Nothing -> fail $ "BinderT.lookupType: unknown variable " ++ pretty name+      Nothing -> error $ "BinderT.lookupType: unknown variable " ++ pretty name       Just t' -> return $ typeOf t'   askScope = BinderT $ gets snd
src/Futhark/Binder/Class.hs view
@@ -21,7 +21,6 @@ where  import Control.Monad.Writer-import qualified Control.Monad.Fail as Fail import qualified Data.Kind  import Futhark.Representation.AST@@ -57,8 +56,7 @@ -- bindings, however. class (Attributes (Lore m),        MonadFreshNames m, Applicative m, Monad m,-       LocalScope (Lore m) m,-       Fail.MonadFail m) =>+       LocalScope (Lore m) m) =>       MonadBinder m where   type Lore m :: Data.Kind.Type   mkExpAttrM :: Pattern (Lore m) -> Exp (Lore m) -> m (ExpAttr (Lore m))
src/Futhark/CLI/Autotune.hs view
@@ -39,7 +39,9 @@ compileOptions opts = do   futhark <- maybe getExecutablePath return $ optFuthark opts   return $ CompileOptions { compFuthark = futhark-                          , compBackend = optBackend opts }+                          , compBackend = optBackend opts+                          , compOptions = mempty+                          }  runOptions :: Path -> Int -> AutotuneOptions -> RunOptions runOptions path timeout_s opts =
src/Futhark/CLI/Bench.hs view
@@ -12,6 +12,7 @@ import Data.Either import Data.Maybe import Data.List+import Data.Ord import qualified Data.Text as T import System.Console.GetOpt import System.Directory@@ -32,6 +33,7 @@                    , optRunner :: String                    , optRuns :: Int                    , optExtraOptions :: [String]+                   , optCompilerOptions :: [String]                    , optJSON :: Maybe FilePath                    , optTimeout :: Int                    , optSkipCompilation :: Bool@@ -43,7 +45,7 @@                    }  initialBenchOptions :: BenchOptions-initialBenchOptions = BenchOptions "c" Nothing "" 10 [] Nothing (-1) False+initialBenchOptions = BenchOptions "c" Nothing "" 10 [] [] Nothing (-1) False                       ["nobench", "disable"] [] Nothing (Just "tuning") Nothing  runBenchmarks :: BenchOptions -> [FilePath] -> IO ()@@ -63,7 +65,8 @@    when (anyFailedToCompile skipped_benchmarks) exitFailure -  results <- concat <$> mapM (runBenchmark opts) compiled_benchmarks+  results <- concat <$> mapM (runBenchmark opts)+             (sortBy (comparing fst) compiled_benchmarks)   case optJSON opts of     Nothing -> return ()     Just file -> LBS.writeFile file $ encodeBenchResults results@@ -88,7 +91,9 @@ compileOptions opts = do   futhark <- maybe getExecutablePath return $ optFuthark opts   return $ CompileOptions { compFuthark = futhark-                          , compBackend = optBackend opts }+                          , compBackend = optBackend opts+                          , compOptions = optCompilerOptions opts+                          }  compileBenchmark :: BenchOptions -> (FilePath, ProgramTest)                  -> IO (Either SkipReason (FilePath, [InputOutputs]))@@ -213,6 +218,12 @@                config { optExtraOptions = opt : optExtraOptions config })      "OPT")     "Pass this option to programs being run."+  , Option [] ["pass-compiler-option"]+    (ReqArg (\opt ->+               Right $ \config ->+               config { optCompilerOptions = opt : optCompilerOptions config })+     "OPT")+    "Pass this option to the compiler (or typechecker if in -t mode)."   , Option [] ["json"]     (ReqArg (\file ->                Right $ \config -> config { optJSON = Just file})
+ src/Futhark/CLI/Check.hs view
@@ -0,0 +1,28 @@+module Futhark.CLI.Check (main) where++import Control.Monad+import Control.Monad.IO.Class+import System.Console.GetOpt+import System.IO++import Futhark.Compiler+import Futhark.Util.Options++newtype CheckConfig = CheckConfig { checkWarn :: Bool }++newCheckConfig :: CheckConfig+newCheckConfig = CheckConfig True++options :: [FunOptDescr CheckConfig]+options = [Option "w" []+           (NoArg $ Right $ \cfg -> cfg { checkWarn = False })+           "Disable all warnings."]++main :: String -> [String] -> IO ()+main = mainWithOptions newCheckConfig options "program" $ \args cfg ->+  case args of+    [file] -> Just $ do+      (warnings, _, _) <- readProgramOrDie file+      when (checkWarn cfg) $+        liftIO $ hPutStr stderr $ show warnings+    _ -> Nothing
src/Futhark/CLI/Dataset.hs view
@@ -13,8 +13,9 @@ import qualified Data.Vector.Unboxed.Mutable as UMVec import qualified Data.Vector.Unboxed as UVec import Data.Vector.Generic (freeze)- import System.Console.GetOpt+import System.Exit+import System.IO import System.Random  import Language.Futhark.Syntax hiding@@ -32,7 +33,8 @@           | null $ optOrders config = Just $ do               maybe_vs <- readValues <$> BS.getContents               case maybe_vs of-                Nothing -> error "Malformed data on standard input."+                Nothing -> do hPutStrLn stderr "Malformed data on standard input."+                              exitFailure                 Just vs ->                   case format config of                     Text -> mapM_ (putStrLn . pretty) vs@@ -66,7 +68,8 @@                 [(n', "")] ->                   Right $ \config -> config { optSeed = n' }                 _ ->-                  Left $ error $ "'" ++ n ++ "' is not an integer.")+                  Left $ do hPutStrLn stderr $ "'" ++ n ++ "' is not an integer."+                            exitFailure)      "SEED")     "The seed to use when initialising the RNG."   , Option "g" ["generate"]@@ -79,7 +82,8 @@                              [g (optRange config) (format config)]                          }                 Left err ->-                  Left $ error err)+                  Left $ do hPutStrLn stderr err+                            exitFailure)      "TYPE")     "Generate a random value of this type."   , Option [] ["text"]@@ -116,7 +120,9 @@                 Right $ \config ->                 config { optRange = set (lower', upper') $ optRange config }               _ ->-                Left $ error $ "Invalid bounds: " ++ b+                Left $ do+                hPutStrLn stderr $ "Invalid bounds for " ++ tname ++ ": " ++ b+                exitFailure             )    "MIN:MAX") $   "Range of " ++ tname ++ " values."
src/Futhark/CLI/Dev.hs view
@@ -3,6 +3,7 @@ module Futhark.CLI.Dev (main) where  import Data.Maybe+import Data.List import Control.Category (id) import Control.Monad import Control.Monad.State@@ -292,6 +293,9 @@   , Option [] ["ast"]     (NoArg $ Right $ \opts -> opts { futharkPrintAST = True })     "Output ASTs instead of prettyprinted programs."+  , Option [] ["safe"]+    (NoArg $ Right $ changeFutharkConfig $ \opts -> opts { futharkSafe = True })+    "Ignore 'unsafe'."   , typedPassOption soacsProg Kernels firstOrderTransform "f"   , soacsPassOption fuseSOACs "o"   , soacsPassOption inlineAndRemoveDeadFunctions []@@ -343,7 +347,12 @@               Right () -> return ()         compile _      _      =           Nothing-        m file config =+        m file config = do+          let p :: (Show a, PP.Pretty a) => [a] -> IO ()+              p = mapM_ putStrLn .+                  intersperse "" .+                  map (if futharkPrintAST config then show else pretty)+           case futharkPipeline config of             PrettyPrint -> liftIO $ do               maybe_prog <- parseFuthark file <$> T.readFile file@@ -359,17 +368,16 @@                            else pretty $ fileProg fm             Defunctorise -> do               (_, imports, src) <- readProgram file-              liftIO $ mapM_ (putStrLn . if futharkPrintAST config then show else pretty) $-                evalState (Defunctorise.transformProg imports) src+              liftIO $ p $ evalState (Defunctorise.transformProg imports) src             Monomorphise -> do               (_, imports, src) <- readProgram file-              liftIO $ mapM_ (putStrLn . if futharkPrintAST config then show else pretty) $+              liftIO $ p $                 flip evalState src $                 Defunctorise.transformProg imports                 >>= Monomorphise.transformProg             Defunctionalise -> do               (_, imports, src) <- readProgram file-              liftIO $ mapM_ (putStrLn . if futharkPrintAST config then show else pretty) $+              liftIO $ p $                 flip evalState src $                 Defunctorise.transformProg imports                 >>= Monomorphise.transformProg
src/Futhark/CLI/Misc.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -- Various small subcommands that are too simple to deserve their own file. module Futhark.CLI.Misc-  ( mainCheck-  , mainImports+  ( mainImports   , mainDataget   ) where@@ -19,21 +18,13 @@ import Futhark.Util.Options import Futhark.Test -mainCheck :: String -> [String] -> IO ()-mainCheck = mainWithOptions () [] "program" $ \args () ->-  case args of-    [file] -> Just $ do-      (warnings, _, _) <- readProgramOrDie file-      liftIO $ hPutStr stderr $ show warnings-    _ -> Nothing- mainImports :: String -> [String] -> IO () mainImports = mainWithOptions () [] "program" $ \args () ->   case args of     [file] -> Just $ do       (_, prog_imports, _) <- readProgramOrDie file       liftIO $ putStr $ unlines $ map (++ ".fut")-        $ filter (\f -> not ("futlib/" `isPrefixOf` f))+        $ filter (\f -> not ("prelude/" `isPrefixOf` f))         $ map fst prog_imports     _ -> Nothing
src/Futhark/CLI/REPL.hs view
@@ -140,34 +140,35 @@      Nothing -> do       -- Load the builtins through the type checker.-      (_, imports, src) <- badOnLeft =<< runExceptT (readLibrary [])+      (_, imports, src) <- badOnLeft show =<< runExceptT (readLibrary [])       -- Then into the interpreter.-      ienv <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx)+      ienv <- foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx)               I.initialCtx $ map (fmap fileProg) imports        -- Then make the prelude available in the type checker.-      (tenv, d, src') <- badOnLeft $ T.checkDec imports src T.initialEnv-                         (T.mkInitialImport ".") $ mkOpen "/futlib/prelude"+      (tenv, d, src') <- badOnLeft pretty $ T.checkDec imports src T.initialEnv+                         (T.mkInitialImport ".") $ mkOpen "/prelude/prelude"       -- Then in the interpreter.-      ienv' <- badOnLeft =<< runInterpreter' (I.interpretDec ienv d)+      ienv' <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv d)       return (imports, src', tenv, ienv')      Just file -> do       (ws, imports, src) <--        badOnLeft =<< liftIO (runExceptT (readProgram file)-                              `Haskeline.catch` \(err::IOException) ->-                                 return (Left (ExternalError (T.pack $ show err))))+        badOnLeft show =<<+        liftIO (runExceptT (readProgram file)+                 `Haskeline.catch` \(err::IOException) ->+                   return (externalErrorS (show err)))       liftIO $ hPrint stderr ws        let imp = T.mkInitialImport "."-      ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $+      ienv1 <- foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $                map (fmap fileProg) imports-      (tenv1, d1, src') <- badOnLeft $ T.checkDec imports src T.initialEnv imp $-                           mkOpen "/futlib/prelude"-      (tenv2, d2, src'') <- badOnLeft $ T.checkDec imports src' tenv1 imp $+      (tenv1, d1, src') <- badOnLeft pretty $ T.checkDec imports src T.initialEnv imp $+                           mkOpen "/prelude/prelude"+      (tenv2, d2, src'') <- badOnLeft pretty $ T.checkDec imports src' tenv1 imp $                             mkOpen $ toPOSIX $ dropExtension file-      ienv2 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv1 d1)-      ienv3 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv2 d2)+      ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)+      ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)       return (imports, src'', tenv2, ienv3)    return FutharkiState { futharkiImports = imports@@ -178,9 +179,9 @@                        , futharkiSkipBreaks = mempty                        , futharkiLoaded = maybe_file                        }-  where badOnLeft :: Show err => Either err a -> ExceptT String IO a-        badOnLeft (Right x) = return x-        badOnLeft (Left err) = throwError $ show err+  where badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a+        badOnLeft _ (Right x) = return x+        badOnLeft p (Left err) = throwError $ p err  getPrompt :: FutharkiM String getPrompt = do@@ -246,7 +247,7 @@   -- that 'import "foo"' is a declaration.  We have to involve a lot   -- of machinery to load this external code before executing the   -- declaration itself.-  let basis = Basis imports src ["/futlib/prelude"]+  let basis = Basis imports src ["/prelude/prelude"]       mkImport = uncurry $ T.mkImportFrom cur_import   imp_r <- runExceptT $ readImports basis (map mkImport $ decImports d) @@ -254,7 +255,7 @@     Left e -> liftIO $ print e     Right (_, imports',  src') ->       case T.checkDec imports' src' tenv cur_import d of-        Left e -> liftIO $ print e+        Left e -> liftIO $ putStrLn $ pretty e         Right (tenv', d', src'') -> do           let new_imports = filter ((`notElem` map fst imports) . fst) imports'           int_r <- runInterpreter $ do@@ -272,16 +273,21 @@ onExp :: UncheckedExp -> FutharkiM () onExp e = do   (imports, src, tenv, ienv) <- getIt-  case showErr (T.checkExp imports src tenv e) of+  case either (Left . pretty) Right $+       T.checkExp imports src tenv e of     Left err -> liftIO $ putStrLn err-    Right (_, e') -> do-      r <- runInterpreter $ I.interpretExp ienv e'-      case r of-        Left err -> liftIO $ print err-        Right v -> liftIO $ putStrLn $ pretty v-    where showErr :: Show a => Either a b -> Either String b-          showErr = either (Left . show) Right+    Right (tparams, e')+      | null tparams -> do+          r <- runInterpreter $ I.interpretExp ienv e'+          case r of+            Left err -> liftIO $ print err+            Right v -> liftIO $ putStrLn $ pretty v +      | otherwise -> liftIO $ do+          putStrLn $ "Inferred type of expression: " ++ pretty (typeOf e')+          putStrLn $ "The following types are ambiguous: " +++            intercalate ", " (map (prettyName . typeParamName) tparams)+ prettyBreaking :: Breaking -> String prettyBreaking b =   prettyStacktrace (breakingAt b) $ map locStr $ NE.toList $ breakingStack b@@ -299,7 +305,7 @@        let top = NE.head callstack           ctx = I.stackFrameCtx top-          tenv = I.typeEnv $ I.ctxEnv ctx+          tenv = I.typeCheckerEnv $ I.ctxEnv ctx           breaking = Breaking callstack 0        -- Are we supposed to skip this breakpoint?  Also, We do not@@ -346,9 +352,9 @@     (True, Nothing) -> liftIO $ T.putStrLn "No file specified and no file previously loaded."     (False, _) -> throwError $ Load $ T.unpack file -genTypeCommand :: (Show err1, Show err2) =>-                  (String -> T.Text -> Either err1 a)-               -> (Imports -> VNameSource -> T.Env -> a -> Either err2 b)+genTypeCommand :: Show err =>+                  (String -> T.Text -> Either err a)+               -> (Imports -> VNameSource -> T.Env -> a -> Either T.TypeError b)                -> (b -> String)                -> Command genTypeCommand f g h e = do@@ -360,7 +366,7 @@       src <- gets futharkiNameSource       (tenv, _) <- gets futharkiEnv       case g imports src tenv e' of-        Left err -> liftIO $ print err+        Left err -> liftIO $ putStrLn $ pretty err         Right x -> liftIO $ putStrLn $ h x  typeCommand :: Command@@ -387,7 +393,7 @@       | frame:_ <- NE.drop i stack -> do           let breaking = Breaking stack i               ctx = I.stackFrameCtx frame-              tenv = I.typeEnv $ I.ctxEnv ctx+              tenv = I.typeCheckerEnv $ I.ctxEnv ctx           modify $ \s -> s { futharkiEnv = (tenv, ctx)                            , futharkiBreaking = Just breaking                            }
src/Futhark/CLI/Run.hs view
@@ -5,7 +5,6 @@  import Control.Monad.Free.Church import Control.Exception-import Data.Bifunctor (first) import Data.List import Data.Loc import Data.Maybe@@ -13,7 +12,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except-import qualified Data.Text as T import qualified Data.Text.IO as T import System.FilePath import System.Exit@@ -80,10 +78,8 @@  putValue :: I.Value -> TypeBase () () -> IO () putValue v t-  | I.isEmptyArray v =-      putStrLn $ "empty(" ++ pretty t' ++ ")"+  | I.isEmptyArray v = putStrLn $ I.prettyEmptyArray t v   | otherwise = putStrLn $ pretty v-  where t' = first (const 0) t `setUniqueness` Nonunique :: ValueType  data InterpreterConfig =   InterpreterConfig { interpreterEntryPoint :: Name@@ -108,25 +104,26 @@                  -> IO (Either String (T.Env, I.Ctx)) newFutharkiState cfg file = runExceptT $ do   (ws, imports, src) <--    badOnLeft =<< liftIO (runExceptT (readProgram file)-                          `Haskeline.catch` \(err::IOException) ->-                             return (Left (ExternalError (T.pack $ show err))))+    badOnLeft show =<<+    liftIO (runExceptT (readProgram file)+            `Haskeline.catch` \(err::IOException) ->+               return (externalErrorS (show err)))   when (interpreterPrintWarnings cfg) $     liftIO $ hPrint stderr ws    let imp = T.mkInitialImport "."-  ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $+  ienv1 <- foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $            map (fmap fileProg) imports-  (tenv1, d1, src') <- badOnLeft $ T.checkDec imports src T.initialEnv imp $-                       mkOpen "/futlib/prelude"-  (tenv2, d2, _) <- badOnLeft $ T.checkDec imports src' tenv1 imp $+  (tenv1, d1, src') <- badOnLeft pretty $ T.checkDec imports src T.initialEnv imp $+                       mkOpen "/prelude/prelude"+  (tenv2, d2, _) <- badOnLeft pretty $ T.checkDec imports src' tenv1 imp $                     mkOpen $ toPOSIX $ dropExtension file-  ienv2 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv1 d1)-  ienv3 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv2 d2)+  ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)+  ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)   return (tenv2, ienv3)-  where badOnLeft :: Show err => Either err a -> ExceptT String IO a-        badOnLeft (Right x) = return x-        badOnLeft (Left err) = throwError $ show err+  where badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a+        badOnLeft _ (Right x) = return x+        badOnLeft p (Left err) = throwError $ p err  mkOpen :: FilePath -> UncheckedDec mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -7,8 +7,9 @@   , GC.asExecutable   ) where -import qualified Language.C.Quote.OpenCL as C+import Control.Monad import Data.List+import qualified Language.C.Quote.OpenCL as C  import qualified Futhark.CodeGen.Backends.GenericC as GC import qualified Futhark.CodeGen.ImpGen.CUDA as ImpGen@@ -27,14 +28,14 @@   res <- ImpGen.compileProg prog   case res of     Left err -> return $ Left err-    Right (Program cuda_code cuda_prelude kernel_names _ sizes prog') ->+    Right (Program cuda_code cuda_prelude kernel_names _ sizes failures prog') ->       let extra = generateBoilerplate cuda_code cuda_prelude-                                      kernel_names sizes+                                      kernel_names sizes failures       in Right <$> GC.compileProg operations extra cuda_includes                    [Space "device", DefaultSpace] cliOptions prog'   where     operations :: GC.Operations OpenCL ()-    operations = GC.Operations+    operations = GC.defaultOperations                  { GC.opsWriteScalar = writeCUDAScalar                  , GC.opsReadScalar  = readCUDAScalar                  , GC.opsAllocate    = allocateCUDABuffer@@ -102,6 +103,7 @@                                 $exp:mem + $exp:idx * sizeof($ty:t),                                 sizeof($ty:t)));                 |]+  GC.stm [C.cstm|if (futhark_context_sync(ctx) != 0) { return 1; }|]   return [C.cexp|$id:val|] readCUDAScalar _ _ _ space _ =   error $ "Cannot write to '" ++ space ++ "' memory space."@@ -184,7 +186,7 @@     cudaSizeClass SizeTile = "tile_size"     cudaSizeClass SizeLocalMemory = "shared_memory"     cudaSizeClass (SizeBespoke x _) = pretty x-callKernel (LaunchKernel name args num_blocks block_size) = do+callKernel (LaunchKernel safety name args num_blocks block_size) = do   args_arr <- newVName "kernel_args"   time_start <- newVName "time_start"   time_end <- newVName "time_end"@@ -202,9 +204,14 @@   let perm_args         | length num_blocks == 3 = [ [C.cinit|&perm[0]|], [C.cinit|&perm[1]|], [C.cinit|&perm[2]|] ]         | otherwise = []-  let args'' = perm_args ++ [ [C.cinit|&$id:a|] | a <- args' ]+      failure_args = take (numFailureParams safety)+                     [[C.cinit|&ctx->global_failure|],+                      [C.cinit|&ctx->failure_is_an_option|],+                      [C.cinit|&ctx->global_failure_args|]]+      args'' = perm_args ++ failure_args ++ [ [C.cinit|&$id:a|] | a <- args' ]       sizes_nonzero = expsNotZero [grid_x, grid_y, grid_z,                       block_x, block_y, block_z]+   GC.stm [C.cstm|     if ($exp:sizes_nonzero) {       int perm[3] = { 0, 1, 2 };@@ -247,6 +254,10 @@                 $string:name, $id:time_end - $id:time_start);       }     }|]++  when (safety >= SafetyFull) $+    GC.stm [C.cstm|ctx->failure_is_an_option = 1;|]+   where     mkDims [] = ([C.cexp|0|] , [C.cexp|0|], [C.cexp|0|])     mkDims [x] = (x, [C.cexp|1|], [C.cexp|1|])
src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs view
@@ -8,19 +8,21 @@ import qualified Language.C.Quote.OpenCL as C  import qualified Futhark.CodeGen.Backends.GenericC as GC-import Futhark.Representation.ExplicitMemory hiding (GetSize, CmpSizeLe, GetSizeMax) import Futhark.CodeGen.ImpCode.OpenCL+import Futhark.CodeGen.Backends.COpenCL.Boilerplate (failureSwitch) import Futhark.Util (chunk, zEncodeString)  import qualified Data.Map as M import Data.FileEmbed (embedStringFile) -+errorMsgNumArgs :: ErrorMsg a -> Int+errorMsgNumArgs = length . errorMsgArgTypes -generateBoilerplate :: String -> String -> [String]+generateBoilerplate :: String -> String -> M.Map KernelName Safety                     -> M.Map Name SizeClass+                    -> [FailureMsg]                     -> GC.CompilerM OpenCL () ()-generateBoilerplate cuda_program cuda_prelude kernel_names sizes = do+generateBoilerplate cuda_program cuda_prelude kernels sizes failures = do   GC.earlyDecls [C.cunit|       $esc:("#include <cuda.h>")       $esc:("#include <nvrtc.h>")@@ -32,7 +34,7 @@    generateSizeFuns sizes   cfg <- generateConfigFuns sizes-  generateContextFuns cfg kernel_names sizes+  generateContextFuns cfg kernels sizes failures   where     cuda_h = $(embedStringFile "rts/c/cuda.h")     free_list_h = $(embedStringFile "rts/c/free_list.h")@@ -222,14 +224,15 @@                        }|])   return cfg -generateContextFuns :: String -> [String]+generateContextFuns :: String -> M.Map KernelName Safety                     -> M.Map Name SizeClass+                    -> [FailureMsg]                     -> GC.CompilerM OpenCL () ()-generateContextFuns cfg kernel_names sizes = do+generateContextFuns cfg kernels sizes failures = do   final_inits <- GC.contextFinalInits   (fields, init_fields) <- GC.contextContents-  let kernel_fields = map (\k -> [C.csdecl|typename CUfunction $id:k;|])-                        kernel_names+  let kernel_fields = map (\k -> [C.csdecl|typename CUfunction $id:k;|]) $+                          M.keys kernels    ctx <- GC.publicDef "context" GC.InitDecl $ \s ->     ([C.cedecl|struct $id:s;|],@@ -241,34 +244,50 @@                          char *error;                          $sdecls:fields                          $sdecls:kernel_fields+                         typename CUdeviceptr global_failure;+                         typename CUdeviceptr global_failure_args;                          struct cuda_context cuda;                          struct sizes sizes;+                         // True if a potentially failing kernel has been enqueued.+                         typename int32_t failure_is_an_option;                        };|])    let set_sizes = zipWith (\i k -> [C.cstm|ctx->sizes.$id:k = cfg->sizes[$int:i];|])                           [(0::Int)..] $ M.keys sizes+      max_failure_args =+        foldl max 0 $ map (errorMsgNumArgs . failureError) failures    GC.publicDef_ "context_new" GC.InitDecl $ \s ->     ([C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|],      [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {-                          struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx));-                          if (ctx == NULL) {-                            return NULL;-                          }-                          ctx->profiling = ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging;+                 struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx));+                 if (ctx == NULL) {+                   return NULL;+                 }+                 ctx->profiling = ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; -                          ctx->cuda.cfg = cfg->cu_cfg;-                          create_lock(&ctx->lock);-                          $stms:init_fields+                 ctx->cuda.cfg = cfg->cu_cfg;+                 create_lock(&ctx->lock); -                          cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts);-                          $stms:(map (loadKernelByName) kernel_names)+                 ctx->failure_is_an_option = 0;+                 $stms:init_fields -                          $stms:final_inits-                          $stms:set_sizes-                          return ctx;-                       }|])+                 cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts); +                 typename int32_t no_error = -1;+                 CUDA_SUCCEED(cuMemAlloc(&ctx->global_failure, sizeof(no_error)));+                 CUDA_SUCCEED(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error)));+                 // The +1 is to avoid zero-byte allocations.+                 CUDA_SUCCEED(cuMemAlloc(&ctx->global_failure_args, sizeof(int32_t)*($int:max_failure_args+1)));++                 $stms:(map loadKernel (M.toList kernels))++                 $stms:final_inits+                 $stms:set_sizes++                 return ctx;+               }|])+   GC.publicDef_ "context_free" GC.InitDecl $ \s ->     ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],      [C.cedecl|void $id:s(struct $id:ctx* ctx) {@@ -280,10 +299,30 @@   GC.publicDef_ "context_sync" GC.InitDecl $ \s ->     ([C.cedecl|int $id:s(struct $id:ctx* ctx);|],      [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                         CUDA_SUCCEED(cuCtxSynchronize());-                         return 0;-                       }|])+                 CUDA_SUCCEED(cuCtxSynchronize());+                 if (ctx->failure_is_an_option) {+                   // Check for any delayed error.+                   typename int32_t failure_idx;+                   CUDA_SUCCEED(+                     cuMemcpyDtoH(&failure_idx,+                                  ctx->global_failure,+                                  sizeof(int32_t)));+                   ctx->failure_is_an_option = 0; +                   if (failure_idx >= 0) {+                     typename int32_t args[$int:max_failure_args+1];+                     CUDA_SUCCEED(+                       cuMemcpyDtoH(&args,+                                    ctx->global_failure_args,+                                    sizeof(args)));++                     $stm:(failureSwitch failures)++                     return 1;+                   }+                 }+               }|])+   GC.publicDef_ "context_get_error" GC.InitDecl $ \s ->     ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|],      [C.cedecl|char* $id:s(struct $id:ctx* ctx) {@@ -304,6 +343,6 @@                }|])    where-    loadKernelByName name =+    loadKernel (name, _) =       [C.cstm|CUDA_SUCCEED(cuModuleGetFunction(&ctx->$id:name,                 ctx->cuda.module, $string:name));|]
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -8,6 +8,7 @@  import Control.Monad hiding (mapM) import Data.List+import qualified Data.Map as M  import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C@@ -26,18 +27,19 @@   res <- ImpGen.compileProg prog   case res of     Left err -> return $ Left err-    Right (Program opencl_code opencl_prelude kernel_names types sizes prog') -> do+    Right (Program opencl_code opencl_prelude kernels+           types sizes failures prog') -> do       let cost_centres =             [copyDevToDev, copyDevToHost, copyHostToDev,              copyScalarToDev, copyScalarFromDev]-            ++ kernel_names+            ++ M.keys kernels       Right <$> GC.compileProg operations                 (generateBoilerplate opencl_code opencl_prelude-                 cost_centres kernel_names types sizes)+                 cost_centres kernels types sizes failures)                 include_opencl_h [Space "device", DefaultSpace]                 cliOptions prog'   where operations :: GC.Operations OpenCL ()-        operations = GC.Operations+        operations = GC.defaultOperations                      { GC.opsCompiler = callKernel                      , GC.opsWriteScalar = writeOpenCLScalar                      , GC.opsReadScalar = readOpenCLScalar@@ -56,20 +58,6 @@                                     "#include <CL/cl.h>",                                     "#endif"] -copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: String-copyDevToDev = "copy_dev_to_dev"-copyDevToHost = "copy_dev_to_host"-copyHostToDev = "copy_host_to_dev"-copyScalarToDev = "copy_scalar_to_dev"-copyScalarFromDev = "copy_scalar_from_dev"--profilingEvent :: String -> C.Exp-profilingEvent name =-  [C.cexp|ctx->profiling_paused ? NULL-          : opencl_get_event(&ctx->opencl,-                             &ctx->$id:(kernelRuns name),-                             &ctx->$id:(kernelRuntime name))|]- cliOptions :: [Option] cliOptions =   commonOptions ++@@ -141,16 +129,23 @@ writeOpenCLScalar _ _ _ space _ _ =   error $ "Cannot write to '" ++ space ++ "' memory space." +-- It is often faster to do a blocking clEnqueueReadBuffer() than to+-- do an async clEnqueueReadBuffer() followed by a clFinish(), even+-- with an in-order command queue.  This is safe if and only if there+-- are no possible outstanding failures. readOpenCLScalar :: GC.ReadScalar OpenCL () readOpenCLScalar mem i t "device" _ = do   val <- newVName "read_res"   GC.decl [C.cdecl|$ty:t $id:val;|]   GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(-                   clEnqueueReadBuffer(ctx->opencl.queue, $exp:mem, CL_TRUE,+                   clEnqueueReadBuffer(ctx->opencl.queue, $exp:mem,+                                       ctx->failure_is_an_option ? CL_FALSE : CL_TRUE,                                        $exp:i * sizeof($ty:t), sizeof($ty:t),                                        &$id:val,                                        0, NULL, $exp:(profilingEvent copyScalarFromDev)));               |]+  GC.stm [C.cstm|if (ctx->failure_is_an_option &&+                     futhark_context_sync(ctx) != 0) { return 1; }|]   return [C.cexp|$id:val|] readOpenCLScalar _ _ _ space _ =   error $ "Cannot read from '" ++ space ++ "' memory space."@@ -175,10 +170,13 @@   GC.stm [C.cstm|     if ($exp:nbytes > 0) {       OPENCL_SUCCEED_OR_RETURN(-        clEnqueueReadBuffer(ctx->opencl.queue, $exp:srcmem, CL_TRUE,+        clEnqueueReadBuffer(ctx->opencl.queue, $exp:srcmem,+                            ctx->failure_is_an_option ? CL_FALSE : CL_TRUE,                             $exp:srcidx, $exp:nbytes,                             $exp:destmem + $exp:destidx,                             0, NULL, $exp:(profilingEvent copyHostToDev)));+      if (ctx->failure_is_an_option &&+          futhark_context_sync(ctx) != 0) { return 1; }    }   |] copyOpenCLMemory destmem destidx (Space "device") srcmem srcidx DefaultSpace nbytes =@@ -267,12 +265,27 @@   let field = "max_" ++ pretty size_class   in GC.stm [C.cstm|$id:v = ctx->opencl.$id:field;|] -callKernel (LaunchKernel name args num_workgroups workgroup_size) = do-  zipWithM_ setKernelArg [(0::Int)..] args+callKernel (LaunchKernel safety name args num_workgroups workgroup_size) = do++  -- The other failure args are set automatically when the kernel is+  -- first created.+  when (safety == SafetyFull) $+    GC.stm [C.cstm|+      OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, 1,+                                              sizeof(ctx->failure_is_an_option),+                                              &ctx->failure_is_an_option));+    |]++  zipWithM_ setKernelArg [numFailureParams safety..] args   num_workgroups' <- mapM GC.compileExp num_workgroups   workgroup_size' <- mapM GC.compileExp workgroup_size   local_bytes <- foldM localBytes [C.cexp|0|] args+   launchKernel name num_workgroups' workgroup_size' local_bytes++  when (safety >= SafetyFull) $+    GC.stm [C.cstm|ctx->failure_is_an_option = 1;|]+   where setKernelArg i (ValueKArg e bt) = do           v <- GC.compileExpToName "kernel_arg" bt e           GC.stm [C.cstm|
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -2,11 +2,14 @@ {-# LANGUAGE TemplateHaskell #-} module Futhark.CodeGen.Backends.COpenCL.Boilerplate   ( generateBoilerplate+  , profilingEvent+  , copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev    , kernelRuntime   , kernelRuns    , commonOptions+  , failureSwitch   ) where  import Data.FileEmbed@@ -20,14 +23,48 @@ import Futhark.CodeGen.OpenCL.Heuristics import Futhark.Util (chunk, zEncodeString) -generateBoilerplate :: String -> String -> [String] -> [String] -> [PrimType]+errorMsgNumArgs :: ErrorMsg a -> Int+errorMsgNumArgs = length . errorMsgArgTypes++failureSwitch :: [FailureMsg] -> C.Stm+failureSwitch failures =+  let printfEscape = let escapeChar '%' = "%%"+                         escapeChar c = [c]+                     in concatMap escapeChar+      onPart (ErrorString s) = printfEscape s+      onPart ErrorInt32{} = "%d"+      onFailure i (FailureMsg emsg@(ErrorMsg parts) backtrace) =+         let msg = concatMap onPart parts ++ "\n" ++ printfEscape backtrace+             msgargs = [ [C.cexp|args[$int:j]|] | j <- [0..errorMsgNumArgs emsg-1] ]+         in [C.cstm|case $int:i: {ctx->error = msgprintf($string:msg, $args:msgargs); break;}|]+      failure_cases =+        zipWith onFailure [(0::Int)..] failures+  in [C.cstm|switch (failure_idx) { $stms:failure_cases }|]+++copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: String+copyDevToDev = "copy_dev_to_dev"+copyDevToHost = "copy_dev_to_host"+copyHostToDev = "copy_host_to_dev"+copyScalarToDev = "copy_scalar_to_dev"+copyScalarFromDev = "copy_scalar_from_dev"++profilingEvent :: String -> C.Exp+profilingEvent name =+  [C.cexp|(ctx->profiling_paused || !ctx->profiling) ? NULL+          : opencl_get_event(&ctx->opencl,+                             &ctx->$id:(kernelRuns name),+                             &ctx->$id:(kernelRuntime name))|]++generateBoilerplate :: String -> String -> [String] -> M.Map KernelName Safety -> [PrimType]                     -> M.Map Name SizeClass+                    -> [FailureMsg]                     -> GC.CompilerM OpenCL () ()-generateBoilerplate opencl_code opencl_prelude profiling_centres kernel_names types sizes = do+generateBoilerplate opencl_code opencl_prelude profiling_centres kernels types sizes failures = do   final_inits <- GC.contextFinalInits    let (ctx_opencl_fields, ctx_opencl_inits, top_decls, later_top_decls) =-        openClDecls profiling_centres kernel_names opencl_code opencl_prelude+        openClDecls profiling_centres kernels opencl_code opencl_prelude    GC.earlyDecls top_decls @@ -240,15 +277,15 @@                          char *error;                          $sdecls:fields                          $sdecls:ctx_opencl_fields+                         typename cl_mem global_failure;+                         typename cl_mem global_failure_args;                          struct opencl_context opencl;                          struct sizes sizes;+                         // True if a potentially failing kernel has been enqueued.+                         typename cl_int failure_is_an_option;                        };|])    mapM_ GC.libDecl later_top_decls-  let set_required_types = [ [C.cstm|required_types |= OPENCL_F64; |]-                           | FloatType Float64 `elem` types ]-      set_sizes = zipWith (\i k -> [C.cstm|ctx->sizes.$id:k = cfg->sizes[$int:i];|])-                          [(0::Int)..] $ M.keys sizes    GC.libDecl [C.cedecl|static void init_context_early(struct $id:cfg *cfg, struct $id:ctx* ctx) {                      ctx->opencl.cfg = cfg->opencl;@@ -265,22 +302,45 @@                               sizeof(struct profiling_record));                      create_lock(&ctx->lock); +                     ctx->failure_is_an_option = 0;                      $stms:init_fields                      $stms:ctx_opencl_inits   }|] +  let set_sizes = zipWith (\i k -> [C.cstm|ctx->sizes.$id:k = cfg->sizes[$int:i];|])+                          [(0::Int)..] $ M.keys sizes+      max_failure_args =+        foldl max 0 $ map (errorMsgNumArgs . failureError) failures+   GC.libDecl [C.cedecl|static int init_context_late(struct $id:cfg *cfg, struct $id:ctx* ctx, typename cl_program prog) {                      typename cl_int error;++                     typename cl_int no_error = -1;+                     ctx->global_failure =+                       clCreateBuffer(ctx->opencl.ctx,+                                      CL_MEM_READ_WRITE | CL_MEM_COPY_HOST_PTR,+                                      sizeof(cl_int), &no_error, &error);+                     OPENCL_SUCCEED_OR_RETURN(error);++                     // The +1 is to avoid zero-byte allocations.+                     ctx->global_failure_args =+                       clCreateBuffer(ctx->opencl.ctx,+                                      CL_MEM_READ_WRITE,+                                      sizeof(cl_int)*($int:max_failure_args+1), NULL, &error);+                     OPENCL_SUCCEED_OR_RETURN(error);+                      // Load all the kernels.-                     $stms:(map (loadKernelByName) kernel_names)+                     $stms:(map loadKernel (M.toList kernels))                       $stms:final_inits-                      $stms:set_sizes                       return 0;   }|] +  let set_required_types = [ [C.cstm|required_types |= OPENCL_F64; |]+                           | FloatType Float64 `elem` types ]+   GC.publicDef_ "context_new" GC.InitDecl $ \s ->     ([C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|],      [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {@@ -294,8 +354,11 @@                            init_context_early(cfg, ctx);                           typename cl_program prog = setup_opencl(&ctx->opencl, opencl_program, required_types, cfg->build_opts);-                          init_context_late(cfg, ctx, prog);-                          return ctx;+                          if (init_context_late(cfg, ctx, prog) == 0) {+                            return ctx;+                          } else {+                            return NULL;+                          }                        }|])    GC.publicDef_ "context_new_with_command_queue" GC.InitDecl $ \s ->@@ -327,10 +390,36 @@   GC.publicDef_ "context_sync" GC.InitDecl $ \s ->     ([C.cedecl|int $id:s(struct $id:ctx* ctx);|],      [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                         ctx->error = OPENCL_SUCCEED_NONFATAL(clFinish(ctx->opencl.queue));-                         return ctx->error != NULL;-                       }|])+                 // Check for any delayed error.+                 typename cl_int failure_idx = -1;+                 if (ctx->failure_is_an_option) {+                   OPENCL_SUCCEED_OR_RETURN(+                     clEnqueueReadBuffer(ctx->opencl.queue,+                                         ctx->global_failure,+                                         CL_FALSE,+                                         0, sizeof(typename cl_int), &failure_idx,+                                         0, NULL, $exp:(profilingEvent copyScalarFromDev)));+                   ctx->failure_is_an_option = 0;+                 } +                 OPENCL_SUCCEED_OR_RETURN(clFinish(ctx->opencl.queue));++                 if (failure_idx >= 0) {+                   typename cl_int args[$int:max_failure_args+1];+                   OPENCL_SUCCEED_OR_RETURN(+                     clEnqueueReadBuffer(ctx->opencl.queue,+                                         ctx->global_failure_args,+                                         CL_TRUE,+                                         0, sizeof(args), &args,+                                         0, NULL, $exp:(profilingEvent copyDevToHost)));++                   $stm:(failureSwitch failures)++                   return 1;+                 }+                 return 0;+               }|])+   GC.publicDef_ "context_get_error" GC.InitDecl $ \s ->     ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|],      [C.cedecl|char* $id:s(struct $id:ctx* ctx) {@@ -367,9 +456,9 @@   GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(&ctx->opencl));|]   mapM_ GC.profileReport $ openClReport profiling_centres -openClDecls :: [String] -> [String] -> String -> String+openClDecls :: [String] -> M.Map KernelName Safety -> String -> String             -> ([C.FieldGroup], [C.Stm], [C.Definition], [C.Definition])-openClDecls profiling_centres kernel_names opencl_program opencl_prelude =+openClDecls profiling_centres kernels opencl_program opencl_prelude =   (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load)   where opencl_program_fragments =           -- Some C compilers limit the size of literal strings, so@@ -381,7 +470,7 @@           [ [C.csdecl|int total_runs;|],             [C.csdecl|long int total_runtime;|] ] ++           [ [C.csdecl|typename cl_kernel $id:name;|]-          | name <- kernel_names ] +++          | name <- M.keys kernels ] ++           concat           [ [ [C.csdecl|typename int64_t $id:(kernelRuntime name);|]             , [C.csdecl|int $id:(kernelRuns name);|]@@ -421,14 +510,27 @@           $esc:openCL_h           static const char *opencl_program[] = {$inits:program_fragments};|] -loadKernelByName :: String -> C.Stm-loadKernelByName name = [C.cstm|{+loadKernel :: (KernelName, Safety) -> C.Stm+loadKernel (name, safety) = [C.cstm|{   ctx->$id:name = clCreateKernel(prog, $string:name, &error);   OPENCL_SUCCEED_FATAL(error);+  $items:set_args   if (ctx->debugging) {     fprintf(stderr, "Created kernel %s.\n", $string:name);   }   }|]+  where set_global_failure =+          [C.citem|OPENCL_SUCCEED_FATAL(+                     clSetKernelArg(ctx->$id:name, 0, sizeof(typename cl_mem),+                                    &ctx->global_failure));|]+        set_global_failure_args =+          [C.citem|OPENCL_SUCCEED_FATAL(+                     clSetKernelArg(ctx->$id:name, 2, sizeof(typename cl_mem),+                                    &ctx->global_failure_args));|]+        set_args = case safety of+                     SafetyNone -> []+                     SafetyCheap -> [set_global_failure]+                     SafetyFull -> [set_global_failure, set_global_failure_args]  kernelRuntime :: String -> String kernelRuntime = (++"_total_runtime")
src/Futhark/CodeGen/Backends/CSOpenCL.hs view
@@ -8,7 +8,7 @@   import Futhark.Error-import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory)+import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory, int32) import Futhark.CodeGen.Backends.CSOpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericCSharp as CS import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp@@ -26,7 +26,7 @@   res <- ImpGen.compileProg prog   case res of     Left err -> return $ Left err-    Right (Imp.Program opencl_code opencl_prelude kernel_names types sizes prog') ->+    Right (Imp.Program opencl_code opencl_prelude kernel_names types sizes failures prog') ->       Right <$> CS.compileProg                   module_name                   CS.emptyConstructor@@ -34,7 +34,7 @@                   defines                   operations                   ()-                  (generateBoilerplate opencl_code opencl_prelude kernel_names types sizes)+                  (generateBoilerplate opencl_code opencl_prelude kernel_names types sizes failures)                   []                   [Imp.Space "device", Imp.Space "local", Imp.DefaultSpace]                   cliOptions@@ -135,13 +135,13 @@                      Imp.SizeLocalMemory -> "MaxLocalMemory"                      Imp.SizeBespoke{} -> "MaxBespoke" -callKernel (Imp.LaunchKernel name args num_workgroups workgroup_size) = do+callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do   num_workgroups' <- mapM CS.compileExp num_workgroups   workgroup_size' <- mapM CS.compileExp workgroup_size   let kernel_size = zipWith mult_exp num_workgroups' workgroup_size'       total_elements = foldl mult_exp (Integer 1) kernel_size       cond = BinOp "!=" total_elements (Integer 0)-  body <- CS.collect $ launchKernel name kernel_size workgroup_size' args+  body <- CS.collect $ launchKernel safety name kernel_size workgroup_size' args   CS.stm $ If cond body []   where mult_exp = BinOp "*" @@ -150,13 +150,21 @@   CS.stm $ Reassign (Var (CS.compileName v)) $     BinOp "<=" (Field (Var "Ctx.Sizes") (zEncodeString $ pretty key)) x' -launchKernel :: String -> [CSExp] -> [CSExp] -> [Imp.KernelArg] -> CS.CompilerM op s ()-launchKernel kernel_name kernel_dims workgroup_dims args = do+launchKernel :: Imp.Safety -> String -> [CSExp] -> [CSExp] -> [Imp.KernelArg] -> CS.CompilerM op s ()+launchKernel safety kernel_name kernel_dims workgroup_dims args = do   let kernel_name' = "Ctx."++kernel_name-  args_stms <- zipWithM (processKernelArg kernel_name') [0..] args -  CS.stm $ Unsafe $ concat args_stms+  let failure_args =+        [ processMemArg kernel_name' 0 $ Var "Ctx.GlobalFailure"+        , processValueArg kernel_name' 1 int32 $ Var "Ctx.GlobalFailureIsAnOption"+        , processMemArg kernel_name' 2 $ Var "Ctx.GlobalFailureArgs"] +  failure_args' <- concat <$> sequence (take (Imp.numFailureParams safety) failure_args)++  args_stms <- zipWithM (processKernelArg kernel_name')+               [toInteger (Imp.numFailureParams safety)..] args+  CS.stm $ Unsafe $ failure_args' ++ concat args_stms+   global_work_size <- newVName' "GlobalWorkSize"   local_work_size <- newVName' "LocalWorkSize"   stop_watch <- newVName' "StopWatch"@@ -172,9 +180,7 @@    let ctx = (++) "Ctx."   let debugEndStmts =-          [ Exp $ CS.simpleCall "OPENCL_SUCCEED" [-              CS.simpleCall "CL10.Finish"-                [Var "Ctx.OpenCL.Queue"]]+          [ Exp $ CS.simpleCall "FutharkContextSync" []           , Exp $ CallMethod (Var stop_watch) (Var "Stop") []           , Assign (Var time_diff) $ asMicroseconds (Var stop_watch)           , AssignOp "+" (Var $ ctx $ kernelRuntime kernel_name) (Var time_diff)@@ -196,28 +202,37 @@            , Var global_work_size, Var local_work_size, Integer 0, Null, Null]]]      ++      [ If (Var "Ctx.Debugging") debugEndStmts [] ]) []-  finishIfSynchronous -  where processKernelArg :: String-                         -> Integer-                         -> Imp.KernelArg-                         -> CS.CompilerM op s [CSStmt]-        processKernelArg kernel argnum (Imp.ValueKArg e bt) = do-          let t = CS.compilePrimTypeToAST bt-          tmp <- newVName' "kernelArg"-          e' <- CS.compileExp e-          err <- newVName' "setargErr"-          let err_var = Var err-          return [ AssignTyped t (Var tmp) (Just e')-                 , Assign err_var $ getKernelCall kernel argnum (CS.sizeOf t) (Addr $ Var tmp)]+  when (safety >= Imp.SafetyFull) $+    CS.stm $ Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 1) -        processKernelArg kernel argnum (Imp.MemKArg v) = do+  finishIfSynchronous++  where processMemArg kernel argnum mem = do           err <- newVName' "setargErr"           dest <- newVName "kArgDest"           let err_var = Var err-          return [ Fixed (Var $ CS.compileName dest) (Addr $ memblockFromMem v)+          return [ Fixed (Var $ CS.compileName dest) (Addr mem)                    [ Assign err_var $ getKernelCall kernel argnum (CS.sizeOf $ Primitive IntPtrT) (Var $ CS.compileName dest)]                  ]++        processValueArg kernel argnum et e = do+          let t = CS.compilePrimTypeToAST et+          tmp <- newVName' "kernelArg"+          err <- newVName' "setargErr"+          let err_var = Var err+          return [ AssignTyped t (Var tmp) (Just e)+                 , Assign err_var $ getKernelCall kernel argnum (CS.sizeOf t) (Addr $ Var tmp)]++        processKernelArg :: String+                         -> Integer+                         -> Imp.KernelArg+                         -> CS.CompilerM op s [CSStmt]+        processKernelArg kernel argnum (Imp.ValueKArg e et) =+          processValueArg kernel argnum et =<< CS.compileExp e++        processKernelArg kernel argnum (Imp.MemKArg v) =+          processMemArg kernel argnum $ memblockFromMem v          processKernelArg kernel argnum (Imp.SharedMemoryKArg (Imp.Count num_bytes)) = do           err <- newVName' "setargErr"
src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs view
@@ -7,7 +7,7 @@  import qualified Data.Map as M -import Futhark.CodeGen.ImpCode.OpenCL hiding (Index, If)+import Futhark.CodeGen.ImpCode.OpenCL hiding (Index, If, SubExp(..)) import Futhark.CodeGen.Backends.GenericCSharp as CS import Futhark.CodeGen.Backends.GenericCSharp.AST as AST import Futhark.CodeGen.OpenCL.Heuristics@@ -20,14 +20,41 @@ intArrayT = Composite $ ArrayT intT stringArrayT = Composite $ ArrayT stringT -generateBoilerplate :: String -> String -> [String] -> [PrimType]+errorMsgNumArgs :: ErrorMsg a -> Int+errorMsgNumArgs = length . errorMsgArgTypes++formatEscape :: String -> String+formatEscape = concatMap escapeChar+  where escapeChar '{' = "{{"+        escapeChar '}' = "}}"+        escapeChar c = [c]++failureCase :: Integer -> FailureMsg -> CSStmt+failureCase i (FailureMsg (ErrorMsg parts) backtrace) =+  If (BinOp "==" (Var "failure_idx") (Integer i))+  [ let (formatstr, formatargs) = onParts 0 parts+    in AST.Assert (AST.Bool False) $+       String (formatstr ++ "\nBacktrace:\n" ++ formatEscape backtrace) :+       formatargs+  ]+  []+  where onParts _ [] = ("", [])+        onParts j (ErrorString s : parts') =+          let (formatstr, formatargs) = onParts j parts'+          in (s ++ formatstr, formatargs)+        onParts j (ErrorInt32 _ : parts') =+          let (formatstr, formatargs) = onParts (j+1) parts'+          in ("{" ++ show j ++ "}" ++ formatstr, Index (Var "args") (IdxExp $ Integer j) : formatargs)++generateBoilerplate :: String -> String -> M.Map KernelName Safety -> [PrimType]                     -> M.Map Name SizeClass+                    -> [FailureMsg]                     -> CS.CompilerM OpenCL () ()-generateBoilerplate opencl_code opencl_prelude kernel_names types sizes = do+generateBoilerplate opencl_code opencl_prelude kernels types sizes failures = do   final_inits <- CS.contextFinalInits    let (opencl_fields, opencl_inits, top_decls, later_top_decls) =-        openClDecls kernel_names opencl_code opencl_prelude+        openClDecls kernels opencl_code opencl_prelude    CS.stm top_decls @@ -133,6 +160,9 @@     , (Primitive $ CSInt Int64T, "PeakMemUsageDevice")     , (Primitive BoolT, "DetailMemory")     , (Primitive BoolT, "Debugging")+    , (CustomT "CLMemoryHandle", "GlobalFailure")+    , (intT, "GlobalFailureIsAnOption")+    , (CustomT "CLMemoryHandle", "GlobalFailureArgs")     , (CustomT "OpenCLContext", "OpenCL")     , (CustomT "Sizes", "Sizes") ]     ++ opencl_fields@@ -155,7 +185,8 @@       set_sizes = zipWith (\i k -> Reassign (Field (Var "Ctx.Sizes") (zEncodeString $ pretty k))                                             (Index (Var "Cfg.Sizes") (IdxExp $ (Integer . toInteger) i)))                           [(0::Int)..] $ M.keys sizes-+      max_failure_args =+        foldl max 0 $ map (errorMsgNumArgs . failureError) failures    CS.stm $ CS.privateFunDef new_ctx VoidT [(CustomT cfg, "Cfg")] $     [ AssignTyped (CustomT "ComputeErrorCode") (Var "error") Nothing@@ -168,35 +199,80 @@     [ AssignTyped (CustomT "CLProgramHandle") (Var "prog")         (Just $ CS.simpleCall "SetupOpenCL" [ Ref $ Var "Ctx"                                             , Var "OpenCLProgram"-                                            , Var "RequiredTypes"])]-    ++ concatMap loadKernelByName kernel_names+                                            , Var "RequiredTypes"])] +++    [ Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 0)+    , Unsafe+      [ Exp $ CS.simpleCall "OPENCL_SUCCEED"+        [CS.simpleCall "OpenCLAllocActual" [ Ref $ Var "Ctx"+                                           , Integer 4+                                           , Ref $ Var "Ctx.GlobalFailure"]]+      , AssignTyped intT (Var "no_failure") (Just (Integer (-1)))+      , Exp $ CS.simpleCall "OPENCL_SUCCEED"+        [CS.simpleCall "CL10.EnqueueWriteBuffer"+         [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailure", AST.Bool True+         , CS.toIntPtr $ Integer 0+         , CS.toIntPtr $ Integer 4+         , CS.toIntPtr $ Addr (Var "no_failure")+         , Integer 0, Null, Null]]++     , Exp $ CS.simpleCall "OPENCL_SUCCEED"+       [CS.simpleCall "OpenCLAllocActual" [ Ref $ Var "Ctx"+                                          , Integer $ toInteger $ 4 * (max_failure_args + 1)+                                          , Ref $ Var "Ctx.GlobalFailureArgs"]]]]+    ++ concatMap loadKernel (M.toList kernels)     ++ final_inits     ++ set_sizes -  CS.stm $ CS.privateFunDef sync_ctx intT []-    [ Exp $ CS.simpleCall "OPENCL_SUCCEED" [CS.simpleCall "CL10.Finish" [Var "Ctx.OpenCL.Queue"]]-    , Return $ Integer 0 ]+  CS.stm $ CS.privateFunDef sync_ctx VoidT []+    [ AssignTyped intT (Var "failure_idx") (Just $ CS.simpleInitClass (pretty intT) [])+    , Unsafe [ CS.assignScalarPointer (Var "failure_idx") (Var "ptr")+             , Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 0)+             , Exp $ CS.simpleCall "OPENCL_SUCCEED" [+                 CS.simpleCall "CL10.EnqueueReadBuffer"+                 [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailure", AST.Bool True+                 , CS.toIntPtr $ Integer 0+                 , CS.toIntPtr $ Integer 4+                 , CS.toIntPtr $ Var "ptr"+                , Integer 0, Null, Null]+                ]+            ] -  CS.debugReport $ openClReport kernel_names+    , If (BinOp "!=" (Var "failure_idx") (Integer (-1)))+      ([ AssignTyped intArrayT (Var "args") $ Just $ CreateArray intT $+         Left $ max_failure_args + 1+       , Unsafe [+           Fixed (Var "ptr") (Addr (Index (Var "args") $ IdxExp $ Integer 0))+           [Exp $ CS.simpleCall "CL10.EnqueueReadBuffer"+            [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailureArgs", AST.Bool True+            , CS.toIntPtr $ Integer 0+            , CS.toIntPtr $ Integer $ toInteger $ 4 * max_failure_args+            , CS.toIntPtr $ Var "ptr"+            , Integer 0, Null, Null]]]] +++        zipWith failureCase [0..] failures)+      []+    ] +  CS.debugReport $ openClReport $ M.keys kernels -openClDecls :: [String] -> String -> String++openClDecls :: M.Map KernelName Safety -> String -> String             -> ([(CSType, String)], [CSStmt], CSStmt, [CSStmt])-openClDecls kernel_names opencl_program opencl_prelude =+openClDecls kernels opencl_program opencl_prelude =   (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load)   where ctx_fields =           [ (intT, "TotalRuns")           , (Primitive $ CSInt Int64T, "TotalRuntime")]           ++ concatMap (\name -> [(CustomT "CLKernelHandle", name)                                  ,(longT, kernelRuntime name)-                                 ,(intT, kernelRuns name)]) kernel_names+                                 ,(intT, kernelRuns name)])+          (M.keys kernels)          ctx_inits =           [ Reassign (Var $ ctx "TotalRuns") (Integer 0)           , Reassign (Var $ ctx "TotalRuntime") (Integer 0) ]           ++ concatMap (\name -> [ Reassign (Var $ (ctx . kernelRuntime) name) (Integer 0)-                                 , Reassign (Var $ (ctx . kernelRuns) name) (Integer 0)]-                  ) kernel_names+                                 , Reassign (Var $ (ctx . kernelRuns) name) (Integer 0)])+          (M.keys kernels)           futhark_context = CS.publicName "Context"@@ -209,8 +285,8 @@           AssignTyped stringArrayT (Var "OpenCLProgram")               (Just $ Collection "string[]" [String $ opencl_prelude ++ opencl_program]) -loadKernelByName :: String -> [CSStmt]-loadKernelByName name =+loadKernel :: (String, Safety) -> [CSStmt]+loadKernel (name, _) =   [ Reassign (Var $ ctx name)       (CS.simpleCall "CL10.CreateKernel" [Var "prog", String name, Out $ Var "error"])   , AST.Assert (BinOp "==" (Var "error") (Integer 0)) []
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -13,6 +13,7 @@   , Operations (..)   , defaultOperations   , OpCompiler+  , ErrorCompiler    , PointerQuals   , MemoryType@@ -41,7 +42,6 @@   , compilePrimExp   , compilePrimValue   , compileExpToName-  , dimSizeToExp   , rawMem   , item   , stm@@ -82,7 +82,7 @@ import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C -import Futhark.CodeGen.ImpCode hiding (dimSizeToExp)+import Futhark.CodeGen.ImpCode import Futhark.MonadFreshNames import Futhark.CodeGen.Backends.SimpleRepresentation import Futhark.CodeGen.Backends.GenericC.Options@@ -133,6 +133,8 @@ -- compilation function. type OpCompiler op s = op -> CompilerM op s () +type ErrorCompiler op s = ErrorMsg Exp -> String -> CompilerM op s ()+ -- | The address space qualifiers for a pointer of the given type with -- the given annotation. type PointerQuals op s = String -> CompilerM op s [C.TypeQual]@@ -179,12 +181,25 @@               , opsMemoryType :: MemoryType op s              , opsCompiler :: OpCompiler op s+             , opsError :: ErrorCompiler op s               , opsFatMemory :: Bool                -- ^ If true, use reference counting.  Otherwise, bare                -- pointers.              } +defError :: ErrorCompiler op s+defError (ErrorMsg parts) stacktrace = do+  free_all_mem <- collect $ mapM_ (uncurry unRefMem) =<< gets compDeclaredMem+  let onPart (ErrorString s) = return ("%s", [C.cexp|$string:s|])+      onPart (ErrorInt32 x) = ("%d",) <$> compileExp x+  (formatstrs, formatargs) <- unzip <$> mapM onPart parts+  let formatstr = "Error: " ++ concat formatstrs ++ "\n\nBacktrace:\n%s"+  stm [C.cstm|{ ctx->error = msgprintf($string:formatstr, $args:formatargs, $string:stacktrace);+                $items:free_all_mem+                return 1;+              }|]+ -- | A set of operations that fail for every operation involving -- non-default memory spaces.  Uses plain pointers and @malloc@ for -- memory management.@@ -198,6 +213,7 @@                                , opsMemoryType = defMemoryType                                , opsCompiler = defCompiler                                , opsFatMemory = True+                               , opsError = defError                                }   where defWriteScalar _ _ _ _ _ =           error "Cannot write to non-default memory space because I am dumb"@@ -218,6 +234,7 @@         defCompiler _ =           error "The default compiler cannot compile extended operations" + data CompilerEnv op s = CompilerEnv {     envOperations :: Operations op s   , envFtable     :: M.Map Name [Type]@@ -373,6 +390,10 @@   toExp (BoolValue False) = C.toExp (0::Int8)   toExp Checked = C.toExp (1::Int8) +instance C.ToExp SubExp where+  toExp (Var v) = C.toExp v+  toExp (Constant c) = C.toExp c+ -- | Construct a publicly visible definition using the specified name -- as the template.  The first returned definition is put in the -- header file, and the second is the implementation.  Returns the public@@ -446,25 +467,30 @@ rawMemCType :: Space -> CompilerM op s C.Type rawMemCType DefaultSpace = return defaultMemBlockType rawMemCType (Space sid) = join $ asks envMemoryType <*> pure sid+rawMemCType (ScalarSpace [] t) =+  return [C.cty|$ty:(primTypeToCType t)[1]|]+rawMemCType (ScalarSpace ds t) =+  return $ foldl' addDim [C.cty|$ty:(primTypeToCType t)|] ds+  where addDim t' d = [C.cty|$ty:t'[$exp:d]|]  fatMemType :: Space -> C.Type fatMemType space =   [C.cty|struct $id:name|]   where name = case space of-          DefaultSpace -> "memblock"           Space sid    -> "memblock_" ++ sid+          _            -> "memblock"  fatMemSet :: Space -> String-fatMemSet DefaultSpace = "memblock_set" fatMemSet (Space sid) = "memblock_set_" ++ sid+fatMemSet _ = "memblock_set"  fatMemAlloc :: Space -> String-fatMemAlloc DefaultSpace = "memblock_alloc" fatMemAlloc (Space sid) = "memblock_alloc_" ++ sid+fatMemAlloc _ = "memblock_alloc"  fatMemUnRef :: Space -> String-fatMemUnRef DefaultSpace = "memblock_unref" fatMemUnRef (Space sid) = "memblock_unref_" ++ sid+fatMemUnRef _ = "memblock_unref"  rawMem :: C.ToExp a => a -> CompilerM op s C.Exp rawMem v = rawMem' <$> asks envFatMemory <*> pure v@@ -491,7 +517,7 @@   free <- case space of     Space sid -> do free_mem <- asks envDeallocate                     collect $ free_mem [C.cexp|block->mem|] [C.cexp|block->desc|] sid-    DefaultSpace -> return [[C.citem|free(block->mem);|]]+    _ -> return [[C.citem|free(block->mem);|]]   ctx_ty <- contextType   let unrefdef = [C.cedecl|static int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) {   if (block->references != NULL) {@@ -517,11 +543,11 @@   -- When allocating a memory block we initialise the reference count to 1.   alloc <- collect $     case space of-      DefaultSpace ->-        stm [C.cstm|block->mem = (char*) malloc(size);|]       Space sid ->         join $ asks envAllocate <*> pure [C.cexp|block->mem|] <*>         pure [C.cexp|size|] <*> pure [C.cexp|desc|] <*> pure sid+      _ ->+        stm [C.cstm|block->mem = (char*) malloc(size);|]   let allocdef = [C.cedecl|static int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) {   if (size < 0) {     panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",@@ -570,14 +596,14 @@                            (long long) ctx->$id:peakname);|])   where mty = fatMemType space         (peakname, usagename, sname, spacedesc) = case space of-          DefaultSpace -> ("peak_mem_usage_default",-                           "cur_mem_usage_default",-                            "memblock",-                            "default space")           Space sid    -> ("peak_mem_usage_" ++ sid,                            "cur_mem_usage_" ++ sid,                            "memblock_" ++ sid,                            "space '" ++ sid ++ "'")+          _ -> ("peak_mem_usage_default",+                "cur_mem_usage_default",+                "memblock",+                "default space")  declMem :: VName -> Space -> CompilerM op s () declMem name space = do@@ -624,11 +650,11 @@                      }|]     else alloc name   where alloc dest = case space of-          DefaultSpace ->-            stm [C.cstm|$exp:dest = (char*) malloc($exp:size);|]           Space sid ->             join $ asks envAllocate <*> rawMem name <*>             pure [C.cexp|$exp:size|] <*> pure [C.cexp|desc|] <*> pure sid+          _ ->+            stm [C.cstm|$exp:dest = (char*) malloc($exp:size);|]  primTypeInfo :: PrimType -> Signedness -> C.Exp primTypeInfo (IntType it) t = case (it, t) of@@ -908,7 +934,7 @@           stm [C.cstm|$exp:mem = $exp:src->mem;|]            let rank = length shape-              maybeCopyDim (VarSize d) i =+              maybeCopyDim (Var d) i =                 Just [C.cstm|$id:d = $exp:src->shape[$int:i];|]               maybeCopyDim _ _ = Nothing @@ -955,9 +981,9 @@           stm [C.cstm|$exp:dest->mem = $id:mem;|]            let rank = length shape-              maybeCopyDim (ConstSize x) i =-                [C.cstm|$exp:dest->shape[$int:i] = $int:x;|]-              maybeCopyDim (VarSize d) i =+              maybeCopyDim (Constant x) i =+                [C.cstm|$exp:dest->shape[$int:i] = $exp:x;|]+              maybeCopyDim (Var d) i =                 [C.cstm|$exp:dest->shape[$int:i] = $id:d;|]           stms $ zipWith maybeCopyDim shape [0..rank-1] @@ -1167,7 +1193,9 @@                   int r;                   /* Run the program once. */                   $stms:pack_input-                  assert($id:sync_ctx(ctx) == 0);+                  if ($id:sync_ctx(ctx) != 0) {+                    panic(1, "%s", $id:error_ctx(ctx));+                  };                   // Only profile last run.                   if (profile_run) {                     $id:unpause_profiling(ctx);@@ -1179,7 +1207,9 @@                   if (r != 0) {                     panic(1, "%s", $id:error_ctx(ctx));                   }-                  assert($id:sync_ctx(ctx) == 0);+                  if ($id:sync_ctx(ctx) != 0) {+                    panic(1, "%s", $id:error_ctx(ctx));+                  };                   if (profile_run) {                     $id:pause_profiling(ctx);                   }@@ -1575,10 +1605,6 @@ compilePrimValue Checked =   [C.cexp|0|] -dimSizeToExp :: DimSize -> C.Exp-dimSizeToExp (ConstSize x) = [C.cexp|$int:x|]-dimSizeToExp (VarSize v)   = [C.cexp|$exp:v|]- derefPointer :: C.Exp -> C.Exp -> C.Type -> C.Exp derefPointer ptr i res_t =   [C.cexp|(($ty:res_t)$exp:ptr)[$exp:i]|]@@ -1627,6 +1653,11 @@           <*> rawMem src <*> compileExp iexp           <*> pure (primTypeToCType restype) <*> pure space <*> pure vol +        compileLeaf (Index src (Count iexp) _ ScalarSpace{} _) = do+          src' <- rawMem src+          iexp' <- compileExp iexp+          return [C.cexp|$exp:src'[$exp:iexp']|]+         compileLeaf (SizeOf t) =           return [C.cexp|(typename int32_t)sizeof($ty:t')|]           where t' = primTypeToCType t@@ -1689,12 +1720,14 @@ compilePrimExp f (BinOpExp bop x y) = do   x' <- compilePrimExp f x   y' <- compilePrimExp f y+  -- Note that integer addition, subtraction, and multiplication are+  -- not handled by explicit operators, but rather by functions.  This+  -- is because we want to implicitly convert them to unsigned+  -- numbers, so we can do overflow without invoking undefined+  -- behaviour.   return $ case bop of-             Add{} -> [C.cexp|$exp:x' + $exp:y'|]              FAdd{} -> [C.cexp|$exp:x' + $exp:y'|]-             Sub{} -> [C.cexp|$exp:x' - $exp:y'|]              FSub{} -> [C.cexp|$exp:x' - $exp:y'|]-             Mul{} -> [C.cexp|$exp:x' * $exp:y'|]              FMul{} -> [C.cexp|$exp:x' * $exp:y'|]              FDiv{} -> [C.cexp|$exp:x' / $exp:y'|]              Xor{} -> [C.cexp|$exp:x' ^ $exp:y'|]@@ -1748,18 +1781,11 @@  compileCode (c1 :>>: c2) = compileCode c1 >> compileCode c2 -compileCode (Assert e (ErrorMsg parts) (loc, locs)) = do+compileCode (Assert e msg (loc, locs)) = do   e' <- compileExp e-  free_all_mem <- collect $ mapM_ (uncurry unRefMem) =<< gets compDeclaredMem-  let onPart (ErrorString s) = return ("%s", [C.cexp|$string:s|])-      onPart (ErrorInt32 x) = ("%d",) <$> compileExp x-  (formatstrs, formatargs) <- unzip <$> mapM onPart parts-  let formatstr = "Error: " ++ concat formatstrs ++ "\n\nBacktrace:\n%s"-  stm [C.cstm|if (!$exp:e') {-                   ctx->error = msgprintf($string:formatstr, $args:formatargs, $string:stacktrace);-                   $items:free_all_mem-                   return 1;-                 }|]+  err <- collect $ join $+         asks (opsError . envOperations) <*> pure msg <*> pure stacktrace+  stm [C.cstm|if (!$exp:e') { $items:err }|]   where stacktrace = prettyStacktrace 0 $ map locStr $ loc:locs  compileCode (Allocate name (Count e) space) = do@@ -1771,7 +1797,7 @@  compileCode (For i it bound body) = do   let i' = C.toIdent i-      it' = intTypeToCType it+      it' = primTypeToCType $ IntType it   bound' <- compileExp bound   body'  <- blockScope $ compileCode body   stm [C.cstm|for ($ty:it' $id:i' = 0; $id:i' < $exp:bound'; $id:i'++) {@@ -1822,6 +1848,12 @@   elemexp' <- compileExp elemexp   stm [C.cstm|$exp:deref = $exp:elemexp';|] +compileCode (Write dest (Count idx) _ ScalarSpace{} _ elemexp) = do+  dest' <- rawMem dest+  idx' <- compileExp idx+  elemexp' <- compileExp elemexp+  stm [C.cstm|$exp:dest'[$exp:idx'] = $exp:elemexp';|]+ compileCode (Write dest (Count idx) elemtype (Space space) vol elemexp) =   join $ asks envWriteScalar     <*> rawMem dest@@ -1837,6 +1869,9 @@ compileCode (DeclareScalar name vol t) = do   let ct = primTypeToCType t   decl [C.cdecl|$tyquals:(volQuals vol) $ty:ct $id:name;|]++compileCode (DeclareArray name ScalarSpace{} _ _) =+  error $ "Cannot declare array " ++ pretty name ++ " in scalar space."  compileCode (DeclareArray name DefaultSpace t vs) = do   name_realtype <- newVName $ baseString name ++ "_realtype"
src/Futhark/CodeGen/Backends/GenericCSharp.hs view
@@ -609,17 +609,17 @@ compilePrimTypeToASText Imp.Cert _ = Primitive BoolT  compileDim :: Imp.DimSize -> CSExp-compileDim (Imp.ConstSize i) = Integer $ toInteger i-compileDim (Imp.VarSize v) = Var $ compileName v+compileDim (Imp.Constant v) = compilePrimValue v+compileDim (Imp.Var v) = Var $ compileName v  unpackDim :: CSExp -> Imp.DimSize -> Int32 -> CompilerM op s ()-unpackDim arr_name (Imp.ConstSize c) i = do+unpackDim arr_name (Imp.Constant c) i = do   let shape_name = Field arr_name "Item2" -- array tuples are currently (data array * dimension array) currently-  let constant_c = Integer $ toInteger c+  let constant_c = compilePrimValue c   let constant_i = Integer $ toInteger i   stm $ Assert (BinOp "==" constant_c (Index shape_name $ IdxExp constant_i)) [String "constant dimension wrong"] -unpackDim arr_name (Imp.VarSize var) i = do+unpackDim arr_name (Imp.Var var) i = do   let shape_name = Field arr_name "Item2"   let src = Index shape_name $ IdxExp $ Integer $ toInteger i   let dest = Var $ compileName var@@ -639,16 +639,16 @@   return $ cast $ Var $ compileName name   where cast = compileTypecastExt bt ept -entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem Imp.DefaultSpace bt ept dims)) = do-  let src = Var $ compileName mem-  let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept-  return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ Right $ map compileDim dims]- entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do   unRefMem mem (Imp.Space sid)   pack_output <- asks envEntryOutput   pack_output mem sid bt ept dims +entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do+  let src = Var $ compileName mem+  let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept+  return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ Right $ map compileDim dims]+ entryPointInput :: (Int, Imp.ExternalValue, CSExp) -> CompilerM op s () entryPointInput (i, Imp.OpaqueValue _ vs, e) =   mapM_ entryPointInput $ zip3 (repeat i) (map Imp.TransparentValue vs) $@@ -659,18 +659,18 @@       cast = compileTypecast bt   stm $ Assign vname' (cast e) -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem Imp.DefaultSpace bt _ dims), e) = do+entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do+  unpack_input <- asks envEntryInput+  unpack <- collect $ unpack_input mem sid bt ept dims e+  stms unpack++entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem _ bt _ dims), e) = do   zipWithM_ (unpackDim e) dims [0..]   let arrayData = Field e "Item1"   let dest = Var $ compileName mem       unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt]   stm $ Assign dest unwrap_call -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do-  unpack_input <- asks envEntryInput-  unpack <- collect $ unpack_input mem sid bt ept dims e-  stms unpack- extValueDescName :: Imp.ExternalValue -> String extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc@@ -803,7 +803,7 @@                              , Lambda (Tuple [Var "acc", Var "val"])                                       [Exp $ BinOp "*" (Var "acc") (Var "val")]                              ]-      emptystr = "empty(" ++ ppArrayType bt [length dims-1, length dims-2..0] ++ ")"+      emptystr = "empty(" ++ ppArrayType bt [0..length dims-1] ++ ")"    printelem <- printStm (Imp.ArrayValue mem space bt ept shape) ind e   return $@@ -878,11 +878,11 @@           src = name           offset = Integer 0       case space of-        DefaultSpace ->-          stm $ Reassign (Var (compileName name'))-                       (simpleCall "allocateMem" [size]) -- FIXME         Space sid ->           allocate name' size sid+        _ ->+          stm $ Reassign (Var (compileName name'))+                       (simpleCall "allocateMem" [size]) -- FIXME       copy dest offset space src offset space size (IntType Int64) -- FIXME       return $ Just (compileName name')     _ -> return Nothing@@ -1154,20 +1154,21 @@ compileExp (Imp.LeafExp (Imp.SizeOf t) _) =   return $ (compileTypecast $ IntType Int32) (Integer $ primByteSize t) -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) DefaultSpace _) _) = do+compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) =+  join $ asks envReadScalar+    <*> pure src <*> compileExp iexp+    <*> pure restype <*> pure space++compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) _ _) _) = do   let src' = compileName src   iexp' <- compileExp iexp   return $ Cast (Primitive $ CSInt Int8T) (Index (Var src') (IdxExp iexp')) -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt DefaultSpace _) _) = do+compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt _ _) _) = do   iexp' <- compileExp iexp   let bt' = compilePrimType bt-  return $ simpleCall ("indexArray_" ++ bt') [Var $ compileName src, iexp']--compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) =-  join $ asks envReadScalar-    <*> pure src <*> compileExp iexp-    <*> pure restype <*> pure space+      iexp'' = BinOp "*" iexp' (sizeOf (compilePrimTypeToAST bt))+  return $ simpleCall ("indexArray_" ++ bt') [Var $ compileName src, iexp'']  compileExp (Imp.BinOpExp op x y) = do   (x', y', simple) <- compileBinOpLike x y@@ -1247,7 +1248,11 @@   stm $ AssignTyped t' (Var $ compileName v) Nothing   where t' = compilePrimTypeToAST t -compileCode (Imp.DeclareArray name DefaultSpace t vs) =+compileCode (Imp.DeclareArray name (Space space) t vs) =+  join $ asks envStaticArray <*>+  pure name <*> pure space <*> pure t <*> pure vs++compileCode (Imp.DeclareArray name _ t vs) =   stms [Assign (Var $ "init_"++name') $         simpleCall "unwrapArray"          [@@ -1261,10 +1266,6 @@        ]   where name' = compileName name -compileCode (Imp.DeclareArray name (Space space) t vs) =-  join $ asks envStaticArray <*>-  pure name <*> pure space <*> pure t <*> pure vs- compileCode (Imp.Comment s code) = do   code' <- blockScope $ compileCode code   stm $ Comment s code'@@ -1303,18 +1304,18 @@   let dest' = Var (compileName dest)   stm $ Exp $ simpleCall "MemblockSetDevice" [Ref $ Var "Ctx", Ref dest', Ref src', String (compileName src)] -compileCode (Imp.Allocate name (Imp.Count e) DefaultSpace) = do-  e' <- compileExp e-  let allocate' = simpleCall "allocateMem" [e']-  let name' = Var (compileName name)-  stm $ Reassign name' allocate'- compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) =   join $ asks envAllocate     <*> pure name     <*> compileExp e     <*> pure space +compileCode (Imp.Allocate name (Imp.Count e) _) = do+  e' <- compileExp e+  let allocate' = simpleCall "allocateMem" [e']+  let name' = Var (compileName name)+  stm $ Reassign name' allocate'+ compileCode (Imp.Free name space) = do   unRefMem name space   tell $ mempty { accFreedMem = [name] }@@ -1335,14 +1336,6 @@     <*> pure src <*> compileExp srcoffset <*> pure srcspace     <*> compileExp size <*> pure (IntType Int64) -- FIXME -compileCode (Imp.Write dest (Imp.Count idx) elemtype DefaultSpace _ elemexp) = do-  idx' <- compileExp idx-  elemexp' <- compileExp elemexp-  let dest' = Var $ compileName dest-  let elemtype' = compileTypecast elemtype-  let ctype = elemtype' elemexp'-  stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype]- compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) =   join $ asks envWriteScalar     <*> pure dest@@ -1351,6 +1344,16 @@     <*> pure space     <*> compileExp elemexp +compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do+  idx' <- compileExp idx+  elemexp' <- compileExp elemexp+  let dest' = Var $ compileName dest+      elemtype' = compileTypecast elemtype+      ctype = elemtype' elemexp'+      idx'' = BinOp "*" idx' (sizeOf (compilePrimTypeToAST elemtype))++  stm $ Exp $ simpleCall "writeScalarArray" [dest', idx'', ctype]+ compileCode Imp.Skip = return ()  blockScope :: CompilerM op s () -> CompilerM op s [CSStmt]@@ -1375,7 +1378,7 @@                                                  , (String . compileName) mem] unRefMem _ DefaultSpace = stm Pass unRefMem _ (Space "local") = stm Pass-unRefMem _ (Space _) = error "The default compiler cannot compile unRefMem for other spaces"+unRefMem _ _ = error "The default compiler cannot compile unRefMem for other spaces"   -- | Public names must have a consistent prefix.@@ -1388,14 +1391,14 @@   stm $ declMem' (compileName name) space  declMem' :: String -> Space -> CSStmt-declMem' name DefaultSpace =-  AssignTyped (Composite $ ArrayT $ Primitive ByteT) (Var name) Nothing declMem' name (Space _) =   AssignTyped (CustomT "OpenCLMemblock") (Var name) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"])+declMem' name _ =+  AssignTyped (Composite $ ArrayT $ Primitive ByteT) (Var name) Nothing  rawMemCSType :: Space -> CSType-rawMemCSType DefaultSpace = Composite $ ArrayT $ Primitive ByteT rawMemCSType (Space _) = CustomT "OpenCLMemblock"+rawMemCSType _ = Composite $ ArrayT $ Primitive ByteT  toIntPtr :: CSExp -> CSExp toIntPtr e = simpleInitClass "IntPtr" [e]
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -390,18 +390,17 @@ compileName = zEncodeString . pretty  compileDim :: Imp.DimSize -> PyExp-compileDim (Imp.ConstSize i) = Integer $ toInteger i-compileDim (Imp.VarSize v) = Var $ compileName v+compileDim (Imp.Constant v) = compilePrimValue v+compileDim (Imp.Var v) = Var $ compileName v  unpackDim :: PyExp -> Imp.DimSize -> Int32 -> CompilerM op s ()-unpackDim arr_name (Imp.ConstSize c) i = do+unpackDim arr_name (Imp.Constant c) i = do   let shape_name = Field arr_name "shape"-  let constant_c = Integer $ toInteger c+  let constant_c = compilePrimValue c   let constant_i = Integer $ toInteger i   stm $ Assert (BinOp "==" constant_c (Index shape_name $ IdxExp constant_i)) $     String "constant dimension wrong"--unpackDim arr_name (Imp.VarSize var) i = do+unpackDim arr_name (Imp.Var var) i = do   let shape_name = Field arr_name "shape"       src = Index shape_name $ IdxExp $ Integer $ toInteger i   stm $ Assign (Var $ compileName var) $ simpleCall "np.int32" [src]@@ -413,12 +412,12 @@ entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) =   return $ simpleCall tf [Var $ compileName name]   where tf = compilePrimToExtNp bt ept-entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem Imp.DefaultSpace bt ept dims)) = do-  let cast = Cast (Var $ compileName mem) (compilePrimTypeExt bt ept)-  return $ simpleCall "createArray" [cast, Tuple $ map compileDim dims] entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do   pack_output <- asks envEntryOutput   pack_output mem sid bt ept dims+entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do+  let cast = Cast (Var $ compileName mem) (compilePrimTypeExt bt ept)+  return $ simpleCall "createArray" [cast, Tuple $ map compileDim dims]  badInput :: Int -> PyExp -> String -> PyStmt badInput i e t =@@ -453,7 +452,15 @@     [Catch (Tuple [Var "TypeError", Var "AssertionError"])      [badInput i e $ prettySigned (s==Imp.TypeUnsigned) bt]] -entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem Imp.DefaultSpace t s dims), e) = do+entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do+  unpack_input <- asks envEntryInput+  unpack <- collect $ unpack_input mem sid bt ept dims e+  stm $ Try unpack+    [Catch (Tuple [Var "TypeError", Var "AssertionError"])+     [badInput i e $ concat (replicate (length dims) "[]") +++     prettySigned (ept==Imp.TypeUnsigned) bt]]++entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem _ t s dims), e) = do   let type_is_wrong =         UnOp "not" $         BinOp "and"@@ -470,14 +477,6 @@    stm $ Assign dest unwrap_call -entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do-  unpack_input <- asks envEntryInput-  unpack <- collect $ unpack_input mem sid bt ept dims e-  stm $ Try unpack-    [Catch (Tuple [Var "TypeError", Var "AssertionError"])-     [badInput i e $ concat (replicate (length dims) "[]") ++-     prettySigned (ept==Imp.TypeUnsigned) bt]]- extValueDescName :: Imp.ExternalValue -> String extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc@@ -562,11 +561,11 @@           src = name           offset = Integer 0       case space of-        DefaultSpace ->-          stm $ Assign (Var (compileName name'))-                       (simpleCall "allocateMem" [size]) -- FIXME         Space sid ->           allocate name' size sid+        _ ->+          stm $ Assign (Var (compileName name'))+                       (simpleCall "allocateMem" [size]) -- FIXME       copy dest offset space src offset space size (IntType Int32) -- FIXME       return $ Just $ compileName name'     _ -> return Nothing@@ -781,17 +780,17 @@ compileExp (Imp.LeafExp (Imp.SizeOf t) _) =   return $ simpleCall (compilePrimToNp $ IntType Int32) [Integer $ primByteSize t] -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt DefaultSpace _) _) = do-  iexp' <- compileExp iexp-  let bt' = compilePrimType bt-  let nptype = compilePrimToNp bt-  return $ simpleCall "indexArray" [Var $ compileName src, iexp', Var bt', Var nptype]- compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) =   join $ asks envReadScalar     <*> pure src <*> compileExp iexp     <*> pure restype <*> pure space +compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt _ _) _) = do+  iexp' <- compileExp iexp+  let bt' = compilePrimType bt+  let nptype = compilePrimToNp bt+  return $ simpleCall "indexArray" [Var $ compileName src, iexp', Var bt', Var nptype]+ compileExp (Imp.BinOpExp op x y) = do   (x', y', simple) <- compileBinOpLike x y   case op of@@ -875,7 +874,11 @@   stm $ Assign (Var $ compileName v) $ Var "True" compileCode Imp.DeclareScalar{} = return () -compileCode (Imp.DeclareArray name DefaultSpace t vs) = do+compileCode (Imp.DeclareArray name (Space space) t vs) =+  join $ asks envStaticArray <*>+  pure name <*> pure space <*> pure t <*> pure vs++compileCode (Imp.DeclareArray name _ t vs) = do   -- It is important to store the Numpy array in a temporary variable   -- to prevent it from going "out-of-scope" before calling   -- unwrapArray (which internally uses the .ctype method); see@@ -896,10 +899,6 @@   where name' = compileName name         arr_name = name' <> "_arr" -compileCode (Imp.DeclareArray name (Space space) t vs) =-  join $ asks envStaticArray <*>-  pure name <*> pure space <*> pure t <*> pure vs- compileCode (Imp.Comment s code) = do   code' <- collect $ compileCode code   stm $ Comment s code'@@ -934,7 +933,13 @@   let dest' = Var (compileName dest)   stm $ Assign dest' src' -compileCode (Imp.Allocate name (Imp.Count e) DefaultSpace) = do+compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) =+  join $ asks envAllocate+    <*> pure name+    <*> compileExp e+    <*> pure space++compileCode (Imp.Allocate name (Imp.Count e) _) = do   e' <- compileExp e   let allocate' = simpleCall "allocateMem" [e']   let name' = Var (compileName name)@@ -943,12 +948,6 @@ compileCode (Imp.Free name _) =   stm $ Assign (Var (compileName name)) None -compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) =-  join $ asks envAllocate-    <*> pure name-    <*> compileExp e-    <*> pure space- compileCode (Imp.Copy dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do   destoffset' <- compileExp destoffset   srcoffset' <- compileExp srcoffset@@ -966,14 +965,6 @@     <*> pure src <*> compileExp srcoffset <*> pure srcspace     <*> compileExp size <*> pure (IntType Int32) -- FIXME -compileCode (Imp.Write dest (Imp.Count idx) elemtype DefaultSpace _ elemexp) = do-  idx' <- compileExp idx-  elemexp' <- compileExp elemexp-  let dest' = Var $ compileName dest-  let elemtype' = compilePrimType elemtype-  let ctype = simpleCall elemtype' [elemexp']-  stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype]- compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) =   join $ asks envWriteScalar     <*> pure dest@@ -981,5 +972,13 @@     <*> pure elemtype     <*> pure space     <*> compileExp elemexp++compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do+  idx' <- compileExp idx+  elemexp' <- compileExp elemexp+  let dest' = Var $ compileName dest+  let elemtype' = compilePrimType elemtype+  let ctype = simpleCall elemtype' [elemexp']+  stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype]  compileCode Imp.Skip = return ()
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -4,6 +4,7 @@   ) where  import Control.Monad+import qualified Data.Map as M  import Futhark.Error import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory)@@ -16,7 +17,6 @@ import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.MonadFreshNames - --maybe pass the config file rather than multiple arguments compileProg :: MonadFreshNames m =>                Maybe String -> Prog ExplicitMemory ->  m (Either InternalError String)@@ -25,9 +25,12 @@   --could probably be a better why do to this..   case res of     Left err -> return $ Left err-    Right (Imp.Program opencl_code opencl_prelude kernel_names types sizes prog')  -> do+    Right (Imp.Program opencl_code opencl_prelude kernels types sizes failures prog')  -> do       --prepare the strings for assigning the kernels and set them as global-      let assign = unlines $ map (\x -> pretty $ Assign (Var ("self."++x++"_var")) (Var $ "program."++x)) kernel_names+      let assign = unlines $+                   map (\x -> pretty $ Assign (Var ("self."++x++"_var"))+                              (Var $ "program."++x)) $+                   M.keys kernels        let defines =             [Assign (Var "synchronous") $ Bool False,@@ -59,7 +62,7 @@                                        , "default_tile_size=default_tile_size"                                        , "default_threshold=default_threshold"                                        , "sizes=sizes"]-                        [Escape $ openClInit types assign sizes]+                        [Escape $ openClInit types assign sizes failures]           options = [ Option { optionLongName = "platform"                              , optionShortName = Just 'p'                              , optionArgument = RequiredArgument "str"@@ -109,7 +112,7 @@                     ]        Right <$> Py.compileProg module_name constructor imports defines operations ()-        [Exp $ Py.simpleCall "self.queue.finish" []] options prog'+        [Exp $ Py.simpleCall "sync" [Var "self"]] options prog'   where operations :: Py.Operations Imp.OpenCL ()         operations = Py.Operations                      { Py.opsCompiler = callKernel@@ -139,24 +142,34 @@   Py.stm $ Assign (Var (Py.compileName v)) $   Var $ "self.max_" ++ pretty size_class -callKernel (Imp.LaunchKernel name args num_workgroups workgroup_size) = do+callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do   num_workgroups' <- mapM (fmap asLong . Py.compileExp) num_workgroups   workgroup_size' <- mapM (fmap asLong . Py.compileExp) workgroup_size   let kernel_size = zipWith mult_exp num_workgroups' workgroup_size'       total_elements = foldl mult_exp (Integer 1) kernel_size       cond = BinOp "!=" total_elements (Integer 0)-  body <- Py.collect $ launchKernel name kernel_size workgroup_size' args++  body <- Py.collect $ launchKernel name safety kernel_size workgroup_size' args   Py.stm $ If cond body []++  when (safety >= Imp.SafetyFull) $+    Py.stm $ Assign (Var "self.failure_is_an_option") $+    Py.compilePrimValue (Imp.IntValue (Imp.Int32Value 1))+   where mult_exp = BinOp "*" -launchKernel :: String -> [PyExp] -> [PyExp] -> [Imp.KernelArg]+launchKernel :: String -> Imp.Safety -> [PyExp] -> [PyExp] -> [Imp.KernelArg]              -> Py.CompilerM op s ()-launchKernel kernel_name kernel_dims workgroup_dims args = do+launchKernel kernel_name safety kernel_dims workgroup_dims args = do   let kernel_dims' = Tuple kernel_dims       workgroup_dims' = Tuple workgroup_dims       kernel_name' = "self." ++ kernel_name ++ "_var"   args' <- mapM processKernelArg args-  Py.stm $ Exp $ Py.simpleCall (kernel_name' ++ ".set_args") args'+  let failure_args = take (Imp.numFailureParams safety)+                     [Var "self.global_failure",+                      Var "self.failure_is_an_option",+                      Var "self.global_failure_args"]+  Py.stm $ Exp $ Py.simpleCall (kernel_name' ++ ".set_args") $ failure_args ++ args'   Py.stm $ Exp $ Py.simpleCall "cl.enqueue_nd_range_kernel"     [Var "self.queue", Var kernel_name', kernel_dims', workgroup_dims']   finishIfSynchronous@@ -194,7 +207,8 @@   Py.stm $ Exp $ Call (Var "cl.enqueue_copy")     [Arg $ Var "self.queue", Arg val', Arg mem',      ArgKeyword "device_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt),-     ArgKeyword "is_blocking" $ Bool True]+     ArgKeyword "is_blocking" $ Var "synchronous"]+  Py.stm $ Exp $ Py.simpleCall "sync" [Var "self"]   return $ Index val' $ IdxExp $ Integer 0  readOpenCLScalar _ _ _ space =@@ -334,4 +348,4 @@  finishIfSynchronous :: Py.CompilerM op s () finishIfSynchronous =-  Py.stm $ If (Var "synchronous") [Exp $ Py.simpleCall "self.queue.finish" []] []+  Py.stm $ If (Var "synchronous") [Exp $ Py.simpleCall "sync" [Var "self"]] []
src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs view
@@ -11,11 +11,16 @@ import qualified Data.Text as T import NeatInterpolation (text) -import Futhark.CodeGen.ImpCode.OpenCL (PrimType(..), SizeClass(..))+import Futhark.CodeGen.ImpCode.OpenCL+  (PrimType(..), SizeClass(..),+   FailureMsg(..), ErrorMsg(..), ErrorMsgPart(..), errorMsgArgTypes) import Futhark.CodeGen.OpenCL.Heuristics import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.Util.Pretty (prettyText) +errorMsgNumArgs :: ErrorMsg a -> Int+errorMsgNumArgs = length . errorMsgArgTypes+ -- | @rts/python/opencl.py@ embedded as a string. openClPrelude :: String openClPrelude = $(embedStringFile "rts/python/opencl.py")@@ -23,9 +28,11 @@ -- | Python code (as a string) that calls the -- @initiatialize_opencl_object@ procedure.  Should be put in the -- class constructor.-openClInit :: [PrimType] -> String -> M.Map Name SizeClass -> String-openClInit types assign sizes = T.unpack [text|+openClInit :: [PrimType] -> String -> M.Map Name SizeClass -> [FailureMsg] -> String+openClInit types assign sizes failures = T.unpack [text| size_heuristics=$size_heuristics+self.global_failure_args_max = $max_num_args+self.failure_msgs=$failure_msgs program = initialise_opencl_object(self,                                    program_src=fut_opencl_src,                                    command_queue=command_queue,@@ -46,6 +53,19 @@         size_heuristics = prettyText $ sizeHeuristicsToPython sizeHeuristicsTable         types' = prettyText $ map (show . pretty) types -- Looks enough like Python.         sizes' = prettyText $ sizeClassesToPython sizes+        max_num_args = prettyText $ foldl max 0 $ map (errorMsgNumArgs . failureError) failures+        failure_msgs = prettyText $ List $ map formatFailure failures++formatFailure :: FailureMsg -> PyExp+formatFailure (FailureMsg (ErrorMsg parts) backtrace) =+  String $ concatMap onPart parts ++ "\n" ++ formatEscape backtrace+  where formatEscape = let escapeChar '{' = "{{"+                           escapeChar '}' = "}}"+                           escapeChar c = [c]+                       in concatMap escapeChar++        onPart (ErrorString s) = formatEscape s+        onPart ErrorInt32{} = "{}"  sizeClassesToPython :: M.Map Name SizeClass -> PyExp sizeClassesToPython = Dict . map f . M.toList
src/Futhark/CodeGen/Backends/SimpleRepresentation.hs view
@@ -5,8 +5,6 @@   , tupleFieldExp   , funName   , defaultMemBlockType-  , intTypeToCType-  , floatTypeToCType   , primTypeToCType   , signedPrimTypeToCType @@ -104,9 +102,11 @@         taggedI s Int32 = s ++ "32"         taggedI s Int64 = s ++ "64" -        mkAdd = simpleIntOp "add" [C.cexp|x + y|]-        mkSub = simpleIntOp "sub" [C.cexp|x - y|]-        mkMul = simpleIntOp "mul" [C.cexp|x * y|]+        -- Use unsigned types for add/sub/mul so we can do+        -- well-defined overflow.+        mkAdd = simpleUintOp "add" [C.cexp|x + y|]+        mkSub = simpleUintOp "sub" [C.cexp|x - y|]+        mkMul = simpleUintOp "mul" [C.cexp|x * y|]         mkUDiv = simpleUintOp "udiv" [C.cexp|x / y|]         mkUMod = simpleUintOp "umod" [C.cexp|x % y|]         mkUMax = simpleUintOp "umax" [C.cexp|x < y ? y : x|]@@ -204,54 +204,54 @@ cIntPrimFuns =   [C.cunit| $esc:("#if defined(__OPENCL_VERSION__)")-   typename int32_t $id:(funName' "popc8") (typename int8_t x) {+   static typename int32_t $id:(funName' "popc8") (typename int8_t x) {       return popcount(x);    }-   typename int32_t $id:(funName' "popc16") (typename int16_t x) {+   static typename int32_t $id:(funName' "popc16") (typename int16_t x) {       return popcount(x);    }-   typename int32_t $id:(funName' "popc32") (typename int32_t x) {+   static typename int32_t $id:(funName' "popc32") (typename int32_t x) {       return popcount(x);    }-   typename int32_t $id:(funName' "popc64") (typename int64_t x) {+   static typename int32_t $id:(funName' "popc64") (typename int64_t x) {       return popcount(x);    } $esc:("#elif defined(__CUDA_ARCH__)")-   typename int32_t $id:(funName' "popc8") (typename int8_t x) {+   static typename int32_t $id:(funName' "popc8") (typename int8_t x) {       return __popc(zext_i8_i32(x));    }-   typename int32_t $id:(funName' "popc16") (typename int16_t x) {+   static typename int32_t $id:(funName' "popc16") (typename int16_t x) {       return __popc(zext_i16_i32(x));    }-   typename int32_t $id:(funName' "popc32") (typename int32_t x) {+   static typename int32_t $id:(funName' "popc32") (typename int32_t x) {       return __popc(x);    }-   typename int32_t $id:(funName' "popc64") (typename int64_t x) {+   static typename int32_t $id:(funName' "popc64") (typename int64_t x) {       return __popcll(x);    } $esc:("#else")-   typename int32_t $id:(funName' "popc8") (typename int8_t x) {+   static typename int32_t $id:(funName' "popc8") (typename int8_t x) {      int c = 0;      for (; x; ++c) {        x &= x - 1;      }      return c;     }-   typename int32_t $id:(funName' "popc16") (typename int16_t x) {+   static typename int32_t $id:(funName' "popc16") (typename int16_t x) {      int c = 0;      for (; x; ++c) {        x &= x - 1;      }      return c;    }-   typename int32_t $id:(funName' "popc32") (typename int32_t x) {+   static typename int32_t $id:(funName' "popc32") (typename int32_t x) {      int c = 0;      for (; x; ++c) {        x &= x - 1;      }      return c;    }-   typename int32_t $id:(funName' "popc64") (typename int64_t x) {+   static typename int32_t $id:(funName' "popc64") (typename int64_t x) {      int c = 0;      for (; x; ++c) {        x &= x - 1;@@ -261,33 +261,115 @@ $esc:("#endif")  $esc:("#if defined(__OPENCL_VERSION__)")-   typename int32_t $id:(funName' "clz8") (typename int8_t x) {+   static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) {+      return mul_hi(a, b);+   }+   static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) {+      return mul_hi(a, b);+   }+   static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) {+      return mul_hi(a, b);+   }+   static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) {+      return mul_hi(a, b);+   }+$esc:("#elif defined(__CUDA_ARCH__)")+   static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) {+     typename uint16_t aa = a;+     typename uint16_t bb = b;+     return (aa * bb) >> 8;+   }+   static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) {+     typename uint32_t aa = a;+     typename uint32_t bb = b;+     return (aa * bb) >> 16;+   }+   static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) {+      return mulhi(a, b);+   }+   static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) {+      return mul64hi(a, b);+   }+$esc:("#else")+   static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) {+     typename uint16_t aa = a;+     typename uint16_t bb = b;+     return (aa * bb) >> 8;+    }+   static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) {+     typename uint32_t aa = a;+     typename uint32_t bb = b;+     return (aa * bb) >> 16;+    }+   static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) {+     typename uint64_t aa = a;+     typename uint64_t bb = b;+     return (aa * bb) >> 32;+    }+   static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) {+     typename __uint128_t aa = a;+     typename __uint128_t bb = b;+     return (aa * bb) >> 64;+    }+$esc:("#endif")++$esc:("#if defined(__OPENCL_VERSION__)")+   static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) {+      return mad_hi(a, b, c);+   }+   static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) {+      return mad_hi(a, b, c);+   }+   static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) {+      return mad_hi(a, b, c);+   }+   static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) {+      return mad_hi(a, b, c);+   }+$esc:("#else")+   static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) {+     return futrts_mul_hi8(a, b) + c;+    }+   static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) {+     return futrts_mul_hi16(a, b) + c;+    }+   static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) {+     return futrts_mul_hi32(a, b) + c;+    }+   static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) {+     return futrts_mul_hi64(a, b) + c;+    }+$esc:("#endif")+++$esc:("#if defined(__OPENCL_VERSION__)")+   static typename int32_t $id:(funName' "clz8") (typename int8_t x) {       return clz(x);    }-   typename int32_t $id:(funName' "clz16") (typename int16_t x) {+   static typename int32_t $id:(funName' "clz16") (typename int16_t x) {       return clz(x);    }-   typename int32_t $id:(funName' "clz32") (typename int32_t x) {+   static typename int32_t $id:(funName' "clz32") (typename int32_t x) {       return clz(x);    }-   typename int32_t $id:(funName' "clz64") (typename int64_t x) {+   static typename int32_t $id:(funName' "clz64") (typename int64_t x) {       return clz(x);    } $esc:("#elif defined(__CUDA_ARCH__)")-   typename int32_t $id:(funName' "clz8") (typename int8_t x) {+   static typename int32_t $id:(funName' "clz8") (typename int8_t x) {       return __clz(zext_i8_i32(x))-24;    }-   typename int32_t $id:(funName' "clz16") (typename int16_t x) {+   static typename int32_t $id:(funName' "clz16") (typename int16_t x) {       return __clz(zext_i16_i32(x))-16;    }-   typename int32_t $id:(funName' "clz32") (typename int32_t x) {+   static typename int32_t $id:(funName' "clz32") (typename int32_t x) {       return __clz(x);    }-   typename int32_t $id:(funName' "clz64") (typename int64_t x) {+   static typename int32_t $id:(funName' "clz64") (typename int64_t x) {       return __clzll(x);    } $esc:("#else")-   typename int32_t $id:(funName' "clz8") (typename int8_t x) {+   static typename int32_t $id:(funName' "clz8") (typename int8_t x) {     int n = 0;     int bits = sizeof(x) * 8;     for (int i = 0; i < bits; i++) {@@ -297,7 +379,7 @@     }     return n;    }-   typename int32_t $id:(funName' "clz16") (typename int16_t x) {+   static typename int32_t $id:(funName' "clz16") (typename int16_t x) {     int n = 0;     int bits = sizeof(x) * 8;     for (int i = 0; i < bits; i++) {@@ -307,7 +389,7 @@     }     return n;    }-   typename int32_t $id:(funName' "clz32") (typename int32_t x) {+   static typename int32_t $id:(funName' "clz32") (typename int32_t x) {     int n = 0;     int bits = sizeof(x) * 8;     for (int i = 0; i < bits; i++) {@@ -317,7 +399,7 @@     }     return n;    }-   typename int32_t $id:(funName' "clz64") (typename int64_t x) {+   static typename int32_t $id:(funName' "clz64") (typename int64_t x) {     int n = 0;     int bits = sizeof(x) * 8;     for (int i = 0; i < bits; i++) {@@ -428,6 +510,30 @@       return atan(x);     } +    static inline float $id:(funName' "cosh32")(float x) {+      return cosh(x);+    }++    static inline float $id:(funName' "sinh32")(float x) {+      return sinh(x);+    }++    static inline float $id:(funName' "tanh32")(float x) {+      return tanh(x);+    }++    static inline float $id:(funName' "acosh32")(float x) {+      return acosh(x);+    }++    static inline float $id:(funName' "asinh32")(float x) {+      return asinh(x);+    }++    static inline float $id:(funName' "atanh32")(float x) {+      return atanh(x);+    }+     static inline float $id:(funName' "atan2_32")(float x, float y) {       return atan2(x,y);     }@@ -482,6 +588,12 @@     static inline float $id:(funName' "lerp32")(float v0, float v1, float t) {       return mix(v0, v1, t);     }+    static inline float $id:(funName' "mad32")(float a, float b, float c) {+      return mad(a,b,c);+    }+    static inline float $id:(funName' "fma32")(float a, float b, float c) {+      return fma(a,b,c);+    } $esc:("#else")     static inline float fmod32(float x, float y) {       return fmodf(x, y);@@ -498,6 +610,12 @@     static inline float $id:(funName' "lerp32")(float v0, float v1, float t) {       return v0 + (v1-v0)*t;     }+    static inline float $id:(funName' "mad32")(float a, float b, float c) {+      return a*b+c;+    }+    static inline float $id:(funName' "fma32")(float a, float b, float c) {+      return fmaf(a,b,c);+    } $esc:("#endif") |] @@ -547,6 +665,30 @@       return atan(x);     } +    static inline double $id:(funName' "cosh64")(double x) {+      return cosh(x);+    }++    static inline double $id:(funName' "sinh64")(double x) {+      return sinh(x);+    }++    static inline double $id:(funName' "tanh64")(double x) {+      return tanh(x);+    }++    static inline double $id:(funName' "acosh64")(double x) {+      return acosh(x);+    }++    static inline double $id:(funName' "asinh64")(double x) {+      return asinh(x);+    }++    static inline double $id:(funName' "atanh64")(double x) {+      return atanh(x);+    }+     static inline double $id:(funName' "atan2_64")(double x, double y) {       return atan2(x,y);     }@@ -559,6 +701,10 @@       return lgamma(x);     } +    static inline double $id:(funName' "fma64")(double a, double b, double c) {+      return fma(a,b,c);+    }+     static inline double $id:(funName' "round64")(double x) {       return rint(x);     }@@ -597,7 +743,7 @@       return p.t;     } -    static inline float fmod64(float x, float y) {+    static inline double fmod64(double x, double y) {       return fmod(x, y);     } @@ -605,9 +751,15 @@     static inline double $id:(funName' "lerp64")(double v0, double v1, double t) {       return mix(v0, v1, t);     }+    static inline double $id:(funName' "mad64")(double a, double b, double c) {+      return mad(a,b,c);+    } $esc:("#else")     static inline double $id:(funName' "lerp64")(double v0, double v1, double t) {       return v0 + (v1-v0)*t;+    }+    static inline double $id:(funName' "mad64")(double a, double b, double c) {+      return a*b+c;     } $esc:("#endif") |]
src/Futhark/CodeGen/ImpCode.hs view
@@ -16,7 +16,7 @@   , ExternalValue (..)   , Param (..)   , paramName-  , Size (..)+  , SubExp(..)   , MemSize   , DimSize   , Type (..)@@ -33,6 +33,7 @@   , index   , ErrorMsg(..)   , ErrorMsgPart(..)+  , errorMsgArgTypes   , ArrayContents(..)      -- * Typed enumerations@@ -42,11 +43,6 @@   , bytes   , withElemType -    -- * Converting from sizes-  , dimSizeToExp--    -- * Analysis-     -- * Re-exports from other modules.   , module Language.Futhark.Core   , module Futhark.Representation.Primitive@@ -62,19 +58,16 @@ import Language.Futhark.Core import Futhark.Representation.Primitive import Futhark.Representation.AST.Syntax-  (Space(..), SpaceId, ErrorMsg(..), ErrorMsgPart(..))+  (SubExp(..), Space(..), SpaceId,+   ErrorMsg(..), ErrorMsgPart(..), errorMsgArgTypes) import Futhark.Representation.AST.Attributes.Names import Futhark.Representation.AST.Pretty () import Futhark.Analysis.PrimExp import Futhark.Util.Pretty hiding (space) import Futhark.Representation.Kernels.Sizes (Count(..)) -data Size = ConstSize Int64-          | VarSize VName-          deriving (Eq, Show)--type MemSize = Size-type DimSize = Size+type MemSize = SubExp+type DimSize = SubExp  data Type = Scalar PrimType | Mem Space @@ -234,12 +227,6 @@ withElemType (Count e) t =   bytes $ ConvOpExp (SExt Int32 Int64) e * LeafExp (SizeOf t) (IntType Int64) -dimSizeToExp :: DimSize -> Count Elements Exp-dimSizeToExp (VarSize v) =-  elements $ LeafExp (ScalarVar v) (IntType Int32)-dimSizeToExp (ConstSize x) =-  elements $ ValueExp $ IntValue $ Int32Value $ fromIntegral x- var :: VName -> PrimType -> Exp var = LeafExp . ScalarVar @@ -268,12 +255,8 @@           block = indent 2 . stack . map ppr  instance Pretty Param where-  ppr (ScalarParam name ptype) =-    ppr ptype <+> ppr name-  ppr (MemParam name space) =-    text "mem" <> space' <+> ppr name-    where space' = case space of Space s      -> text "@" <> text s-                                 DefaultSpace -> mempty+  ppr (ScalarParam name ptype) = ppr ptype <+> ppr name+  ppr (MemParam name space) = text "mem" <> ppr space <+> ppr name  instance Pretty ValueDesc where   ppr (ScalarValue t ept name) =@@ -281,12 +264,10 @@     where ept' = case ept of TypeUnsigned -> text " (unsigned)"                              TypeDirect   -> mempty   ppr (ArrayValue mem space et ept shape) =-    foldr f (ppr et) shape <+> text "at" <+> ppr mem <> space' <+> ept'+    foldr f (ppr et) shape <+> text "at" <+> ppr mem <> ppr space <+> ept'     where f e s = brackets $ s <> comma <> ppr e           ept' = case ept of TypeUnsigned -> text " (unsigned)"                              TypeDirect   -> mempty-          space' = case space of Space s      -> text "@" <> text s-                                 DefaultSpace -> mempty   instance Pretty ExternalValue where@@ -295,10 +276,6 @@     text "opaque" <+> text desc <+>     nestedBlock "{" "}" (stack $ map ppr vs) -instance Pretty Size where-  ppr (ConstSize x) = ppr x-  ppr (VarSize v)   = ppr v- instance Pretty ArrayContents where   ppr (ArrayValues vs) = braces (commasep $ map ppr vs)   ppr (ArrayZeros n) = braces (text "0") <+> text "*" <+> ppr n@@ -316,7 +293,7 @@     indent 2 (ppr body) </>     text "}"   ppr (DeclareMem name space) =-    text "var" <+> ppr name <> text ": mem" <> parens (ppr space)+    text "var" <+> ppr name <> text ": mem" <> ppr space   ppr (DeclareScalar name vol t) =     text "var" <+> ppr name <> text ":" <+> vol' <> ppr t     where vol' = case vol of Volatile -> text "volatile "@@ -370,10 +347,8 @@   ppr (ScalarVar v) =     ppr v   ppr (Index v is bt space vol) =-    ppr v <> langle <> vol' <> ppr bt <> space' <> rangle <> brackets (ppr is)-    where space' = case space of DefaultSpace -> mempty-                                 Space s      -> text "@" <> text s-          vol' = case vol of Volatile -> text "volatile "+    ppr v <> langle <> vol' <> ppr bt <> ppr space <> rangle <> brackets (ppr is)+    where vol' = case vol of Volatile -> text "volatile "                              Nonvolatile -> mempty    ppr (SizeOf t) =@@ -466,14 +441,14 @@     fvBind (oneName i) $ freeIn' bound <> freeIn' body   freeIn' (While cond body) =     freeIn' cond <> freeIn' body-  freeIn' DeclareMem{} =-    mempty+  freeIn' (DeclareMem _ space) =+    freeIn' space   freeIn' DeclareScalar{} =     mempty   freeIn' DeclareArray{} =     mempty-  freeIn' (Allocate name size _) =-    freeIn' name <> freeIn' size+  freeIn' (Allocate name size space) =+    freeIn' name <> freeIn' size <> freeIn' space   freeIn' (Free name _) =     freeIn' name   freeIn' (Copy dest x _ src y _ n) =@@ -488,8 +463,8 @@     freeIn' dests <> freeIn' args   freeIn' (If cond t f) =     freeIn' cond <> freeIn' t <> freeIn' f-  freeIn' (Assert e _ _) =-    freeIn' e+  freeIn' (Assert e msg _) =+    freeIn' e <> foldMap freeIn' msg   freeIn' (Op op) =     freeIn' op   freeIn' (Comment _ code) =@@ -505,7 +480,3 @@ instance FreeIn Arg where   freeIn' (MemArg m) = freeIn' m   freeIn' (ExpArg e) = freeIn' e--instance FreeIn Size where-  freeIn' (VarSize name) = fvName name-  freeIn' (ConstSize _) = mempty
src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -64,6 +64,14 @@               , kernelName :: Name                -- ^ A short descriptive and _unique_ name - should be                -- alphanumeric and without spaces.++              , kernelFailureTolerant :: Bool+                -- ^ If true, this kernel does not need for check+                -- whether we are in a failing state, as it can cope.+                -- Intuitively, it means that the kernel does not+                -- depend on any non-scalar parameters to make control+                -- flow decisions.  Replication, transpose, and copy+                -- kernels are examples of this.               }             deriving (Show) @@ -136,6 +144,7 @@     (text "groups" <+> brace (ppr $ kernelNumGroups kernel) </>      text "group_size" <+> brace (ppr $ kernelGroupSize kernel) </>      text "uses" <+> brace (commasep $ map ppr $ kernelUses kernel) </>+     text "failure_tolerant" <+> ppr (kernelFailureTolerant kernel) </>      text "body" <+> brace (ppr $ kernelBody kernel))  data KernelOp = GetGroupId VName Int@@ -151,6 +160,13 @@               | MemFenceGlobal               | PrivateAlloc VName (Count Bytes Imp.Exp)               | LocalAlloc VName (Count Bytes Imp.Exp)+              | ErrorSync+                -- ^ Perform a local memory barrier and also check+                -- whether any threads have failed an assertion.  Make+                -- sure all threads would reach all 'ErrorSync's if+                -- any of them do.  A failing assertion will jump to+                -- the next following 'ErrorSync', so make sure it's+                -- not inside control flow or similar.               deriving (Show)  -- Atomic operations return the value stored before the update.@@ -210,6 +226,8 @@     ppr name <+> equals <+> text "private_alloc" <> parens (ppr size)   ppr (LocalAlloc name size) =     ppr name <+> equals <+> text "local_alloc" <> parens (ppr size)+  ppr ErrorSync =+    text "error_sync()"   ppr (Atomic _ (AtomicAdd old arr ind x)) =     ppr old <+> text "<-" <+> text "atomic_add" <>     parens (commasep [ppr arr <> brackets (ppr ind), ppr x])
src/Futhark/CodeGen/ImpCode/OpenCL.hs view
@@ -14,7 +14,10 @@        , KernelName        , KernelArg (..)        , OpenCL (..)+       , Safety(..)+       , numFailureParams        , KernelTarget (..)+       , FailureMsg(..)        , module Futhark.CodeGen.ImpCode        , module Futhark.Representation.Kernels.Sizes        )@@ -32,14 +35,22 @@ data Program = Program { openClProgram :: String                        , openClPrelude :: String                          -- ^ Must be prepended to the program.-                       , openClKernelNames :: [KernelName]+                       , openClKernelNames :: M.Map KernelName Safety                        , openClUsedTypes :: [PrimType]                          -- ^ So we can detect whether the device is capable.                        , openClSizes :: M.Map Name SizeClass                          -- ^ Runtime-configurable constants.+                       , openClFailures :: [FailureMsg]+                         -- ^ Assertion failure error messages.                        , hostFunctions :: Functions OpenCL                        } +-- | Something that can go wrong in a kernel.  Part of the machinery+-- for reporting error messages from within kernels.+data FailureMsg = FailureMsg { failureError :: ErrorMsg Exp+                             , failureBacktrace :: String+                             }+ -- | A function calling OpenCL kernels. type Function = Imp.Function OpenCL @@ -58,8 +69,33 @@                  -- ^ Create this much local memory per workgroup.                deriving (Show) +-- | Whether a kernel can potentially fail (because it contains bounds+-- checks and such).+data MayFail = MayFail | CannotFail+             deriving (Show)++-- | Information about bounds checks and how sensitive it is to+-- errors.  Ordered by least demanding to most.+data Safety+  = SafetyNone+    -- ^ Does not need to know if we are in a failing state, and also+    -- cannot fail.+  | SafetyCheap+    -- ^ Needs to be told if there's a global failure, and that's it,+    -- and cannot fail.+  | SafetyFull+    -- ^ Needs all parameters, may fail itself.+    deriving (Eq, Ord, Show)++-- | How many leading failure arguments we must pass when launching a+-- kernel with these safety characteristics.+numFailureParams :: Safety -> Int+numFailureParams SafetyNone = 0+numFailureParams SafetyCheap = 1+numFailureParams SafetyFull = 3+ -- | Host-level OpenCL operation.-data OpenCL = LaunchKernel KernelName [KernelArg] [Exp] [Exp]+data OpenCL = LaunchKernel Safety KernelName [KernelArg] [Exp] [Exp]             | GetSize VName Name             | CmpSizeLe VName Name Exp             | GetSizeMax VName SizeClass
src/Futhark/CodeGen/ImpGen.hs view
@@ -13,8 +13,6 @@   , AllocCompiler   , Operations (..)   , defaultOperations-  , ValueDestination-  , arrayDestination   , MemLocation (..)   , MemEntry (..)   , ScalarEntry (..)@@ -44,7 +42,6 @@     -- * Building Blocks   , ToExp(..)   , compileAlloc-  , subExpToDimSize   , everythingVolatile   , compileBody   , compileBody'@@ -53,15 +50,11 @@   , compileStms   , compileExp   , defCompileExp-  , offsetArray-  , strideArray   , fullyIndexArray   , fullyIndexArray'-  , Imp.dimSizeToExp-  , dimSizeToSubExp   , copy   , copyDWIM-  , copyDWIMDest+  , copyDWIMFix   , copyElementWise   , typeSize @@ -91,7 +84,6 @@ import Control.Monad.State  hiding (mapM, forM, State) import Control.Monad.Writer hiding (mapM, forM) import Control.Monad.Except hiding (mapM, forM)-import qualified Control.Monad.Fail as Fail import Data.Either import Data.Traversable import qualified Data.Map.Strict as M@@ -123,7 +115,6 @@ type CopyCompiler lore op = PrimType                            -> MemLocation                            -> MemLocation-                           -> Count Elements Imp.Exp -- ^ Number of row elements of the source.                            -> ImpM lore op ()  -- | An alternate way of compiling an allocation.@@ -195,9 +186,6 @@                         -- takes care of this array.                       deriving (Show) -arrayDestination :: MemLocation -> ValueDestination-arrayDestination = ArrayDestination . Just- data Env lore op = Env {     envExpCompiler :: ExpCompiler lore op   , envStmsCompiler :: StmsCompiler lore op@@ -240,9 +228,6 @@             MonadWriter (Imp.Code op),             MonadError InternalError) -instance Fail.MonadFail (ImpM lore op) where-  fail = error . ("ImpM.fail: "++)- instance MonadFreshNames (ImpM lore op) where   getNameSource = gets stateNameSource   putNameSource src = modify $ \s -> s { stateNameSource = src }@@ -256,7 +241,7 @@           entryType (ArrayVar _ arrayEntry) =             Array             (entryArrayElemType arrayEntry)-            (Shape $ map dimSizeToSubExp $ entryArrayShape arrayEntry)+            (Shape $ entryArrayShape arrayEntry)             NoUniqueness           entryType (ScalarVar _ scalarEntry) =             Prim $ entryScalarType scalarEntry@@ -326,7 +311,7 @@             -> Prog lore -> m (Either InternalError (Imp.Functions op)) compileProg ops space prog =   modifyNameSource $ \src ->-  case foldM compileFunDef' (newState src) (progFunctions prog) of+  case foldM compileFunDef' (newState src) (progFuns prog) of     Left err -> (Left err, src)     Right s -> (Right $ stateFunctions s, stateNameSource s)   where compileFunDef' s fdef = do@@ -341,10 +326,9 @@     return $ Left $ Imp.ScalarParam name bt   MemMem space ->     return $ Left $ Imp.MemParam name space-  MemArray bt shape _ (ArrayIn mem ixfun) -> do-    shape' <- mapM subExpToDimSize $ shapeDims shape+  MemArray bt shape _ (ArrayIn mem ixfun) ->     return $ Right $ ArrayDecl name bt $-      MemLocation mem shape' $ fmap (toExp' int32) ixfun+    MemLocation mem (shapeDims shape) $ fmap (toExp' int32) ixfun   where name = paramName fparam  data ArrayDecl = ArrayDecl VName PrimType MemLocation@@ -457,11 +441,11 @@               tell ([Imp.ScalarParam out int32],                     M.singleton x $ ScalarDestination out)               put (memseen, M.insert x out arrseen)-              return $ Imp.VarSize out+              return $ Var out             Just out ->-              return $ Imp.VarSize out+              return $ Var out         inspectExtSize (Free se) =-          imp $ subExpToDimSize se+          return se  compileFunDef :: ExplicitMemorish lore =>                  FunDef lore@@ -489,9 +473,10 @@   compileStms (freeIn ses) bnds $     forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se [] -compileBody' :: (ExplicitMemorish lore, attr ~ LetAttr lore)-             => [Param attr] -> Body lore -> ImpM lore op ()-compileBody' = compileBody . patternFromParams+compileBody' :: [Param attr] -> Body lore -> ImpM lore op ()+compileBody' params (Body _ bnds ses) =+  compileStms (freeIn ses) bnds $+    forM_ (zip params ses) $ \(param, se) -> copyDWIM (paramName param) [] se []  compileLoopBody :: Typed attr => [Param attr] -> Body lore -> ImpM lore op () compileLoopBody mergeparams (Body _ bnds ses) = do@@ -592,7 +577,7 @@     ForLoop i it bound loopvars -> do       let setLoopParam (p,a)             | Prim _ <- paramType p =-                copyDWIM (paramName p) [] (Var a) [Imp.vi32 i]+                copyDWIM (paramName p) [] (Var a) [DimFix $ Imp.vi32 i]             | otherwise =                 return () @@ -647,7 +632,7 @@  defCompileBasicOp (Pattern _ [pe]) (Index src slice)   | Just idxs <- sliceIndices slice =-      copyDWIM (patElemName pe) [] (Var src) $ map (toExp' int32) idxs+      copyDWIM (patElemName pe) [] (Var src) $ map (DimFix . toExp' int32) idxs  defCompileBasicOp _ Index{} =   return ()@@ -658,7 +643,7 @@ defCompileBasicOp (Pattern _ [pe]) (Replicate (Shape ds) se) = do   ds' <- mapM toExp ds   is <- replicateM (length ds) (newVName "i")-  copy_elem <- collect $ copyDWIM (patElemName pe) (map Imp.vi32 is) se []+  copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.vi32) is) se []   emit $ foldl (.) id (zipWith (`Imp.For` Int32) is ds') copy_elem  defCompileBasicOp _ Scratch{} =@@ -671,7 +656,7 @@   sFor "i" n' $ \i -> do     let i' = ConvOpExp (SExt Int32 it) i     x <- dPrimV "x" $ e' + i' * s'-    copyDWIM (patElemName pe) [i] (Var x) []+    copyDWIM (patElemName pe) [DimFix i] (Var x) []  defCompileBasicOp (Pattern _ [pe]) (Copy src) =   copyDWIM (patElemName pe) [] (Var src) []@@ -696,8 +681,8 @@       let srcloc = entryArrayLocation yentry           rows = case drop i $ entryArrayShape yentry of                   []  -> error $ "defCompileBasicOp Concat: empty array shape for " ++ pretty y-                  r:_ -> unCount $ Imp.dimSizeToExp r-      copy (elemType $ patElemType pe) destloc srcloc $ arrayOuterSize yentry+                  r:_ -> toExp' int32 r+      copy (elemType $ patElemType pe) destloc srcloc       emit $ Imp.SetScalar offs_glb $ Imp.var offs_glb int32 + rows  defCompileBasicOp (Pattern [] [pe]) (ArrayLit es _)@@ -707,14 +692,14 @@       let t = primValueType v       static_array <- newVName "static_array"       emit $ Imp.DeclareArray static_array dest_space t $ Imp.ArrayValues vs-      let static_src = MemLocation static_array [Imp.ConstSize $ fromIntegral $ length es] $+      let static_src = MemLocation static_array [intConst Int32 $ fromIntegral $ length es] $                        IxFun.iota [fromIntegral $ length es]           entry = MemVar Nothing $ MemEntry dest_space       addVar static_array entry-      copy t dest_mem static_src $ fromIntegral $ length es+      copy t dest_mem static_src   | otherwise =     forM_ (zip [0..] es) $ \(i,e) ->-      copyDWIM (patElemName pe) [fromInteger i] e []+      copyDWIM (patElemName pe) [DimFix $ fromInteger i] e []    where isLiteral (Constant v) = Just v         isLiteral _ = Nothing@@ -804,8 +789,7 @@ memBoundToVarEntry e (MemMem space) =   return $ MemVar e $ MemEntry space memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) = do-  shape' <- mapM subExpToDimSize $ shapeDims shape-  let location = MemLocation mem shape' $ fmap (toExp' int32) ixfun+  let location = MemLocation mem (shapeDims shape) $ fmap (toExp' int32) ixfun   return $ ArrayVar e ArrayEntry { entryArrayLocation = location                                  , entryArrayElemType = bt                                  }@@ -852,16 +836,6 @@         funcallTarget (MemoryDestination name) =           return [name] -subExpToDimSize :: SubExp -> ImpM lore op Imp.DimSize-subExpToDimSize (Var v) =-  return $ Imp.VarSize v-subExpToDimSize (Constant (IntValue (Int64Value i))) =-  return $ Imp.ConstSize $ fromIntegral i-subExpToDimSize (Constant (IntValue (Int32Value i))) =-  return $ Imp.ConstSize $ fromIntegral i-subExpToDimSize Constant{} =-  compilerBugS "Size subexp is not an int32 or int64 constant."- -- | Compile things to 'Imp.Exp'. class ToExp a where   -- | Compile to an 'Imp.Exp', where the type (must must still be a@@ -929,18 +903,15 @@     _              -> compilerBugS $ "Unknown memory block: " ++ pretty name  destinationFromPattern :: ExplicitMemorish lore => Pattern lore -> ImpM lore op Destination-destinationFromPattern pat = fmap (Destination (baseTag <$> maybeHead (patternNames pat))) . mapM inspect $-                             patternElements pat-  where ctx_names = patternContextNames pat-        inspect patElem = do+destinationFromPattern pat =+  fmap (Destination (baseTag <$> maybeHead (patternNames pat))) . mapM inspect $+  patternElements pat+  where inspect patElem = do           let name = patElemName patElem           entry <- lookupVar name           case entry of-            ArrayVar _ (ArrayEntry (MemLocation mem shape ixfun) _) ->-              return $ ArrayDestination $-              if mem `elem` ctx_names-              then Nothing-              else Just $ MemLocation mem shape ixfun+            ArrayVar _ (ArrayEntry MemLocation{} _) ->+              return $ ArrayDestination Nothing             MemVar{} ->               return $ MemoryDestination name @@ -957,8 +928,13 @@                  -> ImpM lore op (VName, Imp.Space, Count Elements Imp.Exp) fullyIndexArray' (MemLocation mem _ ixfun) indices = do   space <- entryMemSpace <$> lookupMemory mem+  let indices' = case space of+                   ScalarSpace ds _ ->+                     let (zero_is, is) = splitFromEnd (length ds) indices+                     in map (const 0) zero_is ++ is+                   _ -> indices   return (mem, space,-          elements $ IxFun.index ixfun indices)+          elements $ IxFun.index ixfun indices')  sliceArray :: MemLocation            -> Slice Imp.Exp@@ -969,40 +945,17 @@         update (_:ds) (DimFix{}:is) = update ds is         update _      _               = [] -offsetArray :: MemLocation-            -> Imp.Exp-            -> MemLocation-offsetArray (MemLocation mem shape ixfun) offset =-  MemLocation mem shape $ IxFun.offsetIndex ixfun offset--strideArray :: MemLocation-            -> Imp.Exp-            -> MemLocation-strideArray (MemLocation mem shape ixfun) stride =-  MemLocation mem shape $ IxFun.strideIndex ixfun stride--arrayOuterSize :: ArrayEntry -> Count Elements Imp.Exp-arrayOuterSize = arrayDimSize 0--arrayDimSize :: Int -> ArrayEntry -> Count Elements Imp.Exp-arrayDimSize i =-  product . map Imp.dimSizeToExp . take 1 . drop i . entryArrayShape- -- More complicated read/write operations that use index functions.  copy :: CopyCompiler lore op-copy bt pat src n = do+copy bt pat src = do   cc <- asks envCopyCompiler-  cc bt pat src n+  cc bt pat src  -- | Use an 'Imp.Copy' if possible, otherwise 'copyElementWise'. defaultCopy :: CopyCompiler lore op-defaultCopy bt dest src n-  | ixFunMatchesInnerShape-      (Shape $ map dimSizeToExp destshape) destIxFun,-    ixFunMatchesInnerShape-      (Shape $ map dimSizeToExp srcshape) srcIxFun,-    Just destoffset <-+defaultCopy bt dest src+  | Just destoffset <-       IxFun.linearWithOffset destIxFun bt_size,     Just srcoffset  <-       IxFun.linearWithOffset srcIxFun bt_size = do@@ -1011,39 +964,40 @@         emit $ Imp.Copy           destmem (bytes destoffset) destspace           srcmem (bytes srcoffset) srcspace $-          (n * row_size) `withElemType` bt+          num_elems `withElemType` bt   | otherwise =-      copyElementWise bt dest src n+      copyElementWise bt dest src   where bt_size = primByteSize bt-        row_size = product $ map Imp.dimSizeToExp $ drop 1 srcshape-        MemLocation destmem destshape destIxFun = dest+        num_elems = Imp.elements $ product $ map (toExp' int32) srcshape+        MemLocation destmem _ destIxFun = dest         MemLocation srcmem srcshape srcIxFun = src  copyElementWise :: CopyCompiler lore op-copyElementWise bt (MemLocation destmem _ destIxFun) (MemLocation srcmem srcshape srcIxFun) n = do-    is <- replicateM (IxFun.rank destIxFun) (newVName "i")+copyElementWise bt dest src = do+    let bounds = map (toExp' int32) $ memLocationShape src+    is <- replicateM (length bounds) (newVName "i")     let ivars = map Imp.vi32 is-        destidx = IxFun.index destIxFun ivars-        srcidx = IxFun.index srcIxFun ivars-        bounds = map unCount $ n : drop 1 (map Imp.dimSizeToExp srcshape)-    srcspace <- entryMemSpace <$> lookupMemory srcmem-    destspace <- entryMemSpace <$> lookupMemory destmem+    (destmem, destspace, destidx) <- fullyIndexArray' dest ivars+    (srcmem, srcspace, srcidx) <- fullyIndexArray' src ivars     vol <- asks envVolatility     emit $ foldl (.) id (zipWith (`Imp.For` Int32) is bounds) $-      Imp.Write destmem (elements destidx) bt destspace vol $-      Imp.index srcmem (elements srcidx) bt srcspace vol+      Imp.Write destmem destidx bt destspace vol $+      Imp.index srcmem srcidx bt srcspace vol  -- | Copy from here to there; both destination and source may be -- indexeded. copyArrayDWIM :: PrimType-              -> MemLocation -> [Imp.Exp]-              -> MemLocation -> [Imp.Exp]+              -> MemLocation -> [DimIndex Imp.Exp]+              -> MemLocation -> [DimIndex Imp.Exp]               -> ImpM lore op (Imp.Code op) copyArrayDWIM bt-  destlocation@(MemLocation _ destshape dest_ixfun) destis-  srclocation@(MemLocation _ srcshape src_ixfun) srcis+  destlocation@(MemLocation _ destshape _) destslice+  srclocation@(MemLocation _ srcshape _) srcslice -  | length srcis == length srcshape, length destis == length destshape = do+  | Just destis <- mapM dimFix destslice,+    Just srcis <- mapM dimFix srcslice,+    length srcis == length srcshape,+    length destis == length destshape = do   (targetmem, destspace, targetoffset) <-     fullyIndexArray' destlocation destis   (srcmem, srcspace, srcoffset) <-@@ -1055,49 +1009,52 @@   | otherwise = do       let destlocation' =             sliceArray destlocation $-            fullSliceNum (IxFun.shape dest_ixfun) $ map DimFix destis+            fullSliceNum (map (toExp' int32) destshape) destslice           srclocation'  =             sliceArray srclocation $-            fullSliceNum (IxFun.shape src_ixfun) $ map DimFix srcis+            fullSliceNum (map (toExp' int32) srcshape) srcslice           destrank = length (memLocationShape destlocation')           srcrank = length (memLocationShape srclocation')       if destrank /= srcrank-        then fail $ "copyArrayDWIM: cannot copy to " +++        then error $ "copyArrayDWIM: cannot copy to " ++              pretty (memLocationName destlocation') ++              " from " ++ pretty (memLocationName srclocation') ++              " because ranks do not match (" ++ pretty destrank ++              " vs " ++ pretty srcrank ++ ")"       else if destlocation' == srclocation'         then return mempty -- Copy would be no-op.-        else collect $ copy bt destlocation' srclocation' $-             product $ map Imp.dimSizeToExp $-             take 1 $ drop (length srcis) srcshape+        else collect $ copy bt destlocation' srclocation'  -- | Like 'copyDWIM', but the target is a 'ValueDestination' -- instead of a variable name.-copyDWIMDest :: ValueDestination -> [Imp.Exp] -> SubExp -> [Imp.Exp]+copyDWIMDest :: ValueDestination -> [DimIndex Imp.Exp] -> SubExp -> [DimIndex Imp.Exp]              -> ImpM lore op ()  copyDWIMDest _ _ (Constant v) (_:_) =   compilerBugS $   unwords ["copyDWIMDest: constant source", pretty v, "cannot be indexed."]-copyDWIMDest pat dest_is (Constant v) [] =-  case pat of-  ScalarDestination name ->-    emit $ Imp.SetScalar name $ Imp.ValueExp v-  MemoryDestination{} ->-    compilerBugS $-    unwords ["copyDWIMDest: constant source", pretty v, "cannot be written to memory destination."]-  ArrayDestination (Just 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.ValueExp v-  ArrayDestination Nothing ->-    compilerBugS "copyDWIMDest: ArrayDestination Nothing"+copyDWIMDest pat dest_slice (Constant v) [] =+  case mapM dimFix dest_slice of+    Nothing ->+      compilerBugS $+      unwords ["copyDWIMDest: constant source", pretty v, "with slice destination."]+    Just dest_is ->+      case pat of+        ScalarDestination name ->+          emit $ Imp.SetScalar name $ Imp.ValueExp v+        MemoryDestination{} ->+          compilerBugS $+          unwords ["copyDWIMDest: constant source", pretty v, "cannot be written to memory destination."]+        ArrayDestination (Just 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.ValueExp v+        ArrayDestination Nothing ->+          compilerBugS "copyDWIMDest: ArrayDestination Nothing"   where bt = primValueType v -copyDWIMDest dest dest_is (Var src) src_is = do+copyDWIMDest dest dest_slice (Var src) src_slice = do   src_entry <- lookupVar src   case (dest, src_entry) of     (MemoryDestination mem, MemVar _ (MemEntry space)) ->@@ -1111,33 +1068,43 @@       compilerBugS $       unwords ["copyDWIMDest: source", pretty src, "is a memory block."] -    (_, ScalarVar _ (ScalarEntry _)) | not $ null src_is ->+    (_, ScalarVar _ (ScalarEntry _)) | not $ null src_slice ->       compilerBugS $-      unwords ["copyDWIMDest: prim-typed source", pretty src, "with nonzero indices", pretty src_is]+      unwords ["copyDWIMDest: prim-typed source", pretty src, "with slice", pretty src_slice] -    (ScalarDestination name, _) | not $ null dest_is ->+    (ScalarDestination name, _) | not $ null dest_slice ->       compilerBugS $-      unwords ["copyDWIMDest: prim-typed target", pretty name, "with nonzero indices", pretty dest_is]+      unwords ["copyDWIMDest: prim-typed target", pretty name, "with slice", pretty dest_slice]      (ScalarDestination name, ScalarVar _ (ScalarEntry pt)) ->       emit $ Imp.SetScalar name $ Imp.var src pt -    (ScalarDestination name, ArrayVar _ arr) -> do-      let bt = entryArrayElemType arr-      (mem, space, i) <--        fullyIndexArray' (entryArrayLocation arr) src_is-      vol <- asks envVolatility-      emit $ Imp.SetScalar name $ Imp.index mem i bt space vol+    (ScalarDestination name, ArrayVar _ arr)+      | Just src_is <- mapM dimFix src_slice -> do+          let bt = entryArrayElemType arr+          (mem, space, i) <-+            fullyIndexArray' (entryArrayLocation arr) src_is+          vol <- asks envVolatility+          emit $ Imp.SetScalar name $ Imp.index mem i bt space vol+      | otherwise ->+          compilerBugS $+          unwords ["copyDWIMDest: prim-typed target and array-typed source", pretty src,+                   "with slice", pretty src_slice]      (ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do       let src_loc = entryArrayLocation src_arr           bt = entryArrayElemType src_arr-      emit =<< copyArrayDWIM bt dest_loc dest_is src_loc src_is+      emit =<< copyArrayDWIM bt dest_loc dest_slice src_loc src_slice -    (ArrayDestination (Just dest_loc), ScalarVar _ (ScalarEntry bt)) -> 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)+    (ArrayDestination (Just dest_loc), ScalarVar _ (ScalarEntry bt))+      | Just dest_is <- mapM dimFix dest_slice -> 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)+      | otherwise ->+          compilerBugS $+          unwords ["copyDWIMDest: array-typed target and prim-typed source", pretty src,+                   "with slice", pretty dest_slice]      (ArrayDestination Nothing, _) ->       return () -- Nothing to do; something else set some memory@@ -1147,9 +1114,9 @@ -- indexeded.  If so, they better be arrays of enough dimensions. -- This function will generally just Do What I Mean, and Do The Right -- Thing.  Both destination and source must be in scope.-copyDWIM :: VName -> [Imp.Exp] -> SubExp -> [Imp.Exp]+copyDWIM :: VName -> [DimIndex Imp.Exp] -> SubExp -> [DimIndex Imp.Exp]          -> ImpM lore op ()-copyDWIM dest dest_is src src_is = do+copyDWIM dest dest_slice src src_slice = do   dest_entry <- lookupVar dest   let dest_target =         case dest_entry of@@ -1161,8 +1128,13 @@            MemVar _ _ ->             MemoryDestination dest-  copyDWIMDest dest_target dest_is src src_is+  copyDWIMDest dest_target dest_slice src src_slice +-- | As 'copyDWIM', but implicitly 'DimFix'es the indexes.+copyDWIMFix :: VName -> [Imp.Exp] -> SubExp -> [Imp.Exp] -> ImpM lore op ()+copyDWIMFix dest dest_is src src_is =+  copyDWIM dest (map DimFix dest_is) src (map DimFix src_is)+ -- | @compileAlloc pat size space@ allocates @n@ bytes of memory in @space@, -- writing the result to @dest@, which must be a single -- 'MemoryDestination',@@ -1177,13 +1149,6 @@     Just allocator' -> allocator' (patElemName mem) e' compileAlloc pat _ _ =   compilerBugS $ "compileAlloc: Invalid pattern: " ++ pretty pat--dimSizeToSubExp :: Imp.Size -> SubExp-dimSizeToSubExp (Imp.ConstSize n) = constant n-dimSizeToSubExp (Imp.VarSize v) = Var v--dimSizeToExp :: Imp.Size -> Imp.Exp-dimSizeToExp = toExp' int32 . primExpFromSubExp int32 . dimSizeToSubExp  -- | The number of bytes needed to represent the array in a -- straightforward contiguous format.
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -133,9 +133,8 @@  callKernelCopy :: CopyCompiler ExplicitMemory Imp.HostOp callKernelCopy bt-  destloc@(MemLocation destmem destshape destIxFun)+  destloc@(MemLocation destmem _ destIxFun)   srcloc@(MemLocation srcmem srcshape srcIxFun)-  n   | Just (destoffset, srcoffset,           num_arrays, size_x, size_y,           src_elems, dest_elems) <- isMapTransposeKernel bt destloc srcloc = do@@ -148,23 +147,19 @@          Imp.ExpArg src_elems, Imp.ExpArg dest_elems]    | bt_size <- primByteSize bt,-    ixFunMatchesInnerShape-      (Shape $ map (Imp.unCount . Imp.dimSizeToExp) destshape) destIxFun,-    ixFunMatchesInnerShape-      (Shape $ map (Imp.unCount . Imp.dimSizeToExp) srcshape) srcIxFun,     Just destoffset <-       IxFun.linearWithOffset destIxFun bt_size,     Just srcoffset  <-       IxFun.linearWithOffset srcIxFun bt_size = do-        let row_size = product $ map dimSizeToExp $ drop 1 srcshape+        let num_elems = Imp.elements $ product $ map (toExp' int32) srcshape         srcspace <- entryMemSpace <$> lookupMemory srcmem         destspace <- entryMemSpace <$> lookupMemory destmem         emit $ Imp.Copy           destmem (bytes destoffset) destspace           srcmem (bytes srcoffset) srcspace $-          (n * row_size) `Imp.withElemType` bt+          num_elems `Imp.withElemType` bt -  | otherwise = sCopy bt destloc srcloc n+  | otherwise = sCopy bt destloc srcloc  mapTransposeForType :: PrimType -> CallKernelGen Name mapTransposeForType bt = do@@ -294,26 +289,24 @@   (MemLocation _ _ srcIxFun)   | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size,     (perm, destshape) <- unzip perm_and_destshape,-    srcshape' <- IxFun.shape srcIxFun,     Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size,     Just (r1, r2, _) <- isMapTranspose perm =-    isOk (product srcshape') (product destshape) destshape swap r1 r2 dest_offset src_offset+      isOk (product destshape) destshape swap r1 r2 dest_offset src_offset   | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size,     Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size,     (perm, srcshape) <- unzip perm_and_srcshape,-    destshape' <- IxFun.shape destIxFun,     Just (r1, r2, _) <- isMapTranspose perm =-    isOk (product srcshape) (product destshape') srcshape id r1 r2 dest_offset src_offset+      isOk (product srcshape) srcshape id r1 r2 dest_offset src_offset   | otherwise =-    Nothing+      Nothing   where bt_size = primByteSize bt         swap (x,y) = (y,x) -        isOk src_elems dest_elems shape f r1 r2 dest_offset src_offset = do+        isOk elems shape f r1 r2 dest_offset src_offset = do           let (num_arrays, size_x, size_y) = getSizes shape f r1 r2           return (dest_offset, src_offset,                   num_arrays, size_x, size_y,-                  src_elems, dest_elems)+                  elems, elems)          getSizes shape f r1 r2 =           let (mapped, notmapped) = splitAt r1 shape
src/Futhark/CodeGen/ImpGen/Kernels/Base.hs view
@@ -38,7 +38,6 @@ import Data.Maybe import qualified Data.Map.Strict as M import Data.List-import Data.Loc  import Prelude hiding (quot, rem) @@ -74,15 +73,6 @@ keyWithEntryPoint fname key =   nameFromString $ nameToString fname ++ "." ++ nameToString key -noAssert :: MonadError InternalError m => [SrcLoc] -> m a-noAssert locs =-  compilerLimitationS $-  unlines [ "Cannot compile assertion at " ++-            intercalate " -> " (reverse $ map locStr locs) ++-            " inside parallel kernel."-          , "As a workaround, surround the expression with 'unsafe'."]-- allocLocal, allocPrivate :: AllocCompiler ExplicitMemory Imp.KernelOp allocLocal mem size =   sOp $ Imp.LocalAlloc mem size@@ -93,11 +83,10 @@             -> Pattern ExplicitMemory             -> SubExp -> Space             -> ImpM ExplicitMemory Imp.KernelOp ()-kernelAlloc _ (Pattern _ [_]) _ (Space space)-  | space `M.member` allScalarMemory =-      return () -- Handled by the declaration of the memory block,-                -- which is then translated to an actual scalar-                -- variable during C code generation.+kernelAlloc _ (Pattern _ [_]) _ ScalarSpace{} =+  -- Handled by the declaration of the memory block, which is then+  -- translated to an actual scalar variable during C code generation.+  return () kernelAlloc _ (Pattern _ [mem]) size (Space "private") = do   size' <- toExp size   allocPrivate (patElemName mem) $ Imp.bytes size'@@ -121,10 +110,9 @@   compilerBugS $ "Invalid target for splitSpace: " ++ pretty pat  compileThreadExp :: ExpCompiler ExplicitMemory Imp.KernelOp-compileThreadExp _ (BasicOp (Assert _ _ (loc, locs))) = noAssert $ loc:locs compileThreadExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =   forM_ (zip [0..] es) $ \(i,e) ->-  copyDWIM (patElemName dest) [fromIntegral (i::Int32)] e []+  copyDWIMFix (patElemName dest) [fromIntegral (i::Int32)] e [] compileThreadExp dest e =   defCompileExp dest e @@ -165,14 +153,13 @@ groupCopy constants to to_is from from_is = do   ds <- mapM toExp . arrayDims =<< subExpType from   groupCoverSpace constants ds $ \is ->-    copyDWIM to (to_is++ is) from (from_is ++ is)+    copyDWIMFix to (to_is++ is) from (from_is ++ is)  compileGroupExp :: KernelConstants -> ExpCompiler ExplicitMemory Imp.KernelOp-compileGroupExp _ _ (BasicOp (Assert _ _ (loc, locs))) = noAssert $ loc:locs -- The static arrays stuff does not work inside kernels. compileGroupExp _ (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =   forM_ (zip [0..] es) $ \(i,e) ->-  copyDWIM (patElemName dest) [fromIntegral (i::Int32)] e []+  copyDWIMFix (patElemName dest) [fromIntegral (i::Int32)] e [] compileGroupExp constants (Pattern _ [dest]) (BasicOp (Copy arr)) = do   groupCopy constants (patElemName dest) [] (Var arr) []   sOp Imp.LocalBarrier@@ -182,7 +169,7 @@ compileGroupExp constants (Pattern _ [dest]) (BasicOp (Replicate ds se)) = do   ds' <- mapM toExp $ shapeDims ds   groupCoverSpace constants ds' $ \is ->-    copyDWIM (patElemName dest) is se (drop (shapeRank ds) is)+    copyDWIMFix (patElemName dest) is se (drop (shapeRank ds) is)   sOp Imp.LocalBarrier compileGroupExp constants (Pattern _ [dest]) (BasicOp (Iota n e s _)) = do   n' <- toExp n@@ -190,7 +177,7 @@   s' <- toExp s   groupLoop constants n' $ \i' -> do     x <- dPrimV "x" $ e' + i' * s'-    copyDWIM (patElemName dest) [i'] (Var x) []+    copyDWIMFix (patElemName dest) [i'] (Var x) []   sOp Imp.LocalBarrier  compileGroupExp _ dest e =@@ -198,9 +185,8 @@  sanityCheckLevel :: SegLevel -> InKernelGen () sanityCheckLevel SegThread{} = return ()-sanityCheckLevel SegThreadScalar{} = return () sanityCheckLevel SegGroup{} =-  fail "compileGroupOp: unexpected group-level SegOp."+  error "compileGroupOp: unexpected group-level SegOp."  compileGroupSpace :: KernelConstants -> SegLevel -> SegSpace -> InKernelGen () compileGroupSpace constants lvl space = do@@ -245,7 +231,7 @@            sComment "All locks start out unlocked" $             groupCoverSpace constants [kernelGroupSize constants] $ \is ->-            copyDWIM locks is (intConst Int32 0) []+            copyDWIMFix locks is (intConst Int32 0) []            return (Just l', f l' (Space "local") local_subhistos) @@ -265,7 +251,7 @@     zipWithM_ (compileThreadResult space constants) (patternElements pat) $     kernelBodyResult body -  sOp Imp.LocalBarrier+  sOp Imp.ErrorSync  compileGroupOp constants pat (Inner (SegOp (SegScan lvl space scan_op _ _ body))) = do   compileGroupSpace constants lvl space@@ -275,11 +261,11 @@   sWhen (isActive $ unSegSpace space) $     compileStms mempty (kernelBodyStms body) $     forM_ (zip (patternNames pat) $ kernelBodyResult body) $ \(dest, res) ->-    copyDWIM dest+    copyDWIMFix dest     (map (`Imp.var` int32) ltids)     (kernelResultSubExp res) [] -  sOp Imp.LocalBarrier+  sOp Imp.ErrorSync    let segment_size = last dims'       crossesSegment from to = (to-from) .>. (to `rem` segment_size)@@ -305,10 +291,10 @@     let (red_res, map_res) =           splitAt (segRedResults ops) $ kernelBodyResult body     forM_ (zip tmp_arrs red_res) $ \(dest, res) ->-      copyDWIM dest (map (`Imp.var` int32) ltids) (kernelResultSubExp res) []+      copyDWIMFix dest (map (`Imp.var` int32) ltids) (kernelResultSubExp res) []     zipWithM_ (compileThreadResult space constants) map_pes map_res -  sOp Imp.LocalBarrier+  sOp Imp.ErrorSync    case dims' of     -- Nonsegmented case (or rather, a single segment) - this we can@@ -317,10 +303,10 @@       forM_ (zip ops tmps_for_ops) $ \(op, tmps) ->         groupReduce constants dim' (segRedLambda op) tmps -      sOp Imp.LocalBarrier+      sOp Imp.ErrorSync        forM_ (zip red_pes tmp_arrs) $ \(pe, arr) ->-        copyDWIM (patElemName pe) [] (Var arr) [0]+        copyDWIMFix (patElemName pe) [] (Var arr) [0]      _ -> do       -- Segmented intra-group reductions are turned into (regular)@@ -332,11 +318,11 @@       forM_ (zip ops tmps_for_ops) $ \(op, tmps) ->         groupScan constants (Just crossesSegment) (product dims') (segRedLambda op) tmps -      sOp Imp.LocalBarrier+      sOp Imp.ErrorSync        let segment_is = map Imp.vi32 $ init ltids       forM_ (zip red_pes tmp_arrs) $ \(pe, arr) ->-        copyDWIM (patElemName pe) segment_is (Var arr) (segment_is ++ [last dims'-1])+        copyDWIMFix (patElemName pe) segment_is (Var arr) (segment_is ++ [last dims'-1])        sOp Imp.LocalBarrier @@ -377,10 +363,10 @@           dLParams $ lambdaParams lam           sLoopNest shape $ \is -> do             forM_ (zip vs_params op_vs) $ \(p, v) ->-              copyDWIM (paramName p) [] v is+              copyDWIMFix (paramName p) [] v is             do_op (bin_is ++ is) -  sOp Imp.LocalBarrier+  sOp Imp.ErrorSync  compileGroupOp _ pat _ =   compilerBugS $ "compileGroupOp: cannot compile rhs of binding " ++ pretty pat@@ -511,7 +497,7 @@         everythingVolatile $         sComment "bind lhs" $         forM_ (zip acc_params arrs) $ \(acc_p, arr) ->-        copyDWIM (paramName acc_p) [] (Var arr) bucket+        copyDWIMFix (paramName acc_p) [] (Var arr) bucket    let op_body = sComment "execute operation" $                 compileBody' acc_params $ lambdaBody op@@ -537,7 +523,7 @@       release_lock       break_loop     fence-  where writeArray bucket arr val = copyDWIM arr bucket val []+  where writeArray bucket arr val = copyDWIMFix arr bucket val []  atomicUpdateCAS :: Space -> PrimType                 -> VName -> VName@@ -559,7 +545,7 @@   -- XXX: CUDA may generate really bad code if this is not a volatile   -- read.  Unclear why.  The later reads are volatile, so maybe   -- that's it.-  everythingVolatile $ copyDWIM old [] (Var arr) bucket+  everythingVolatile $ copyDWIMFix old [] (Var arr) bucket    (arr', _a_space, bucket_offset) <- fullyIndexArray arr bucket @@ -833,14 +819,14 @@         readReduceArgument param arr           | Prim _ <- paramType param = do               let i = local_tid + Imp.vi32 offset-              copyDWIM (paramName param) [] (Var arr) [i]+              copyDWIMFix (paramName param) [] (Var arr) [i]           | otherwise = do               let i = global_tid + Imp.vi32 offset-              copyDWIM (paramName param) [] (Var arr) [i]+              copyDWIMFix (paramName param) [] (Var arr) [i]          writeReduceOpResult param arr           | Prim _ <- paramType param =-              copyDWIM arr [local_tid] (Var $ paramName param) []+              copyDWIMFix arr [local_tid] (Var $ paramName param) []           | otherwise =               return () @@ -851,7 +837,7 @@           -> [VName]           -> ImpM ExplicitMemory Imp.KernelOp () groupScan constants seg_flag w lam arrs = do-  when (any (not . primType . paramType) $ lambdaParams lam) $+  unless (all (primType . paramType) $ lambdaParams lam) $     compilerLimitationS "Cannot compile parallel scans with array element type."    renamed_lam <- renameLambda lam@@ -1066,9 +1052,13 @@             dPrimV_ v $ flatf constants             f constants -sKernel :: Operations ExplicitMemory Imp.KernelOp-        -> KernelConstants -> Name -> ImpM ExplicitMemory Imp.KernelOp a -> CallKernelGen ()-sKernel ops constants name m = do+sKernelFailureTolerant :: Bool+                       -> Operations ExplicitMemory Imp.KernelOp+                       -> KernelConstants+                       -> Name+                       -> ImpM ExplicitMemory Imp.KernelOp a+                       -> CallKernelGen ()+sKernelFailureTolerant tol ops constants name m = do   body <- makeAllMemoryGlobal $ subImpM_ ops m   uses <- computeKernelUses body mempty   emit $ Imp.Op $ Imp.CallKernel Imp.Kernel@@ -1077,8 +1067,13 @@     , Imp.kernelNumGroups = [kernelNumGroups constants]     , Imp.kernelGroupSize = [kernelGroupSize constants]     , Imp.kernelName = name+    , Imp.kernelFailureTolerant = tol     } +sKernel :: Operations ExplicitMemory Imp.KernelOp+        -> KernelConstants -> Name -> ImpM ExplicitMemory Imp.KernelOp a -> CallKernelGen ()+sKernel = sKernelFailureTolerant False+ -- | A kernel with the given number of threads, running per-thread code. sKernelSimple :: String -> Imp.Exp               -> (KernelConstants -> InKernelGen ())@@ -1092,16 +1087,16 @@     f constants  copyInGroup :: CopyCompiler ExplicitMemory Imp.KernelOp-copyInGroup pt destloc srcloc n = do+copyInGroup pt destloc srcloc = do   dest_space <- entryMemSpace <$> lookupMemory (memLocationName destloc)   src_space <- entryMemSpace <$> lookupMemory (memLocationName srcloc)    if isScalarMem dest_space && isScalarMem src_space     then memLocationName destloc <-- Imp.var (memLocationName srcloc) pt-    else copyElementWise pt destloc srcloc n+    else copyElementWise pt destloc srcloc -  where isScalarMem (Space space) = space `M.member` allScalarMemory-        isScalarMem DefaultSpace = False+  where isScalarMem ScalarSpace{} = True+        isScalarMem _ = False  threadOperations, groupOperations :: KernelConstants                                   -> Operations ExplicitMemory Imp.KernelOp@@ -1138,10 +1133,10 @@       name = nameFromString $ "replicate_" ++              show (baseTag $ kernelGlobalThreadIdVar constants) -  sKernel (threadOperations constants) constants name $ do+  sKernelFailureTolerant True (threadOperations constants) constants name $ do     set_constants     sWhen (kernelThreadActive constants) $-      copyDWIM arr is' se $ drop (length ds) is'+      copyDWIMFix arr is' se $ drop (length ds) is'  replicateFunction :: PrimType -> CallKernelGen Imp.Function replicateFunction bt = do@@ -1183,7 +1178,7 @@           fname <- replicateForType v_t'           emit $ Imp.Call [] fname             [Imp.MemArg arr_mem,-             Imp.ExpArg $ unCount $ product $ map dimSizeToExp arr_shape,+             Imp.ExpArg $ product $ map (toExp' int32) arr_shape,              Imp.ExpArg $ toExp' v_t' v]     _ -> return Nothing @@ -1208,7 +1203,7 @@   let name = nameFromString $ "iota_" ++              show (baseTag $ kernelGlobalThreadIdVar constants) -  sKernel (threadOperations constants) constants name $ do+  sKernelFailureTolerant True (threadOperations constants) constants name $ do     set_constants     let gtid = kernelGlobalThreadId constants     sWhen (kernelThreadActive constants) $ do@@ -1221,28 +1216,26 @@ sCopy :: PrimType       -> MemLocation       -> MemLocation-      -> Imp.Count Imp.Elements Imp.Exp       -> CallKernelGen () sCopy bt   destloc@(MemLocation destmem _ _)   srcloc@(MemLocation srcmem srcshape _)-  n = do+  = do   -- Note that the shape of the destination and the source are   -- necessarily the same.-  let shape = map dimSizeToExp srcshape-      shape_se = map (Imp.unCount . dimSizeToExp) srcshape-      kernel_size = Imp.unCount $ n * product (drop 1 shape)+  let shape = map (toExp' int32) srcshape+      kernel_size = product shape    (constants, set_constants) <- simpleKernelConstants kernel_size "copy"    let name = nameFromString $ "copy_" ++              show (baseTag $ kernelGlobalThreadIdVar constants) -  sKernel (threadOperations constants) constants name $ do+  sKernelFailureTolerant True (threadOperations constants) constants name $ do     set_constants      let gtid = kernelGlobalThreadId constants-        dest_is = unflattenIndex shape_se gtid+        dest_is = unflattenIndex shape gtid         src_is = dest_is      (_, destspace, destidx) <- fullyIndexArray' destloc dest_is@@ -1257,21 +1250,18 @@                    -> InKernelGen ()  compileGroupResult _ constants pe (TileReturns [(w,per_group_elems)] what) = do-  dest_loc <- entryArrayLocation <$> lookupArray (patElemName pe)-  let dest_loc_offset = offsetArray dest_loc offset-      dest' = arrayDestination dest_loc_offset   n <- toExp . arraySize 0 =<< lookupType what    -- Avoid loop for the common case where each thread is statically   -- known to write at most one element.   if toExp' int32 per_group_elems == kernelGroupSize constants     then sWhen (offset + ltid .<. toExp' int32 w) $-         copyDWIMDest dest' [ltid] (Var what) [ltid]+         copyDWIMFix (patElemName pe) [ltid + offset] (Var what) [ltid]     else     sFor "i" (n `quotRoundingUp` kernelGroupSize constants) $ \i -> do       j <- fmap Imp.vi32 $ dPrimV "j" $            kernelGroupSize constants * i + ltid-      sWhen (j .<. n) $ copyDWIMDest dest' [j] (Var what) [j]+      sWhen (j .<. n) $ copyDWIMFix (patElemName pe) [j + offset] (Var what) [j]   where ltid = kernelLocalThreadId constants         offset = toExp' int32 per_group_elems * kernelGroupId constants @@ -1283,7 +1273,7 @@   is_for_thread <- mapM (dPrimV "thread_out_index") $ zipWith (+) group_is local_is    sWhen (isActive $ zip is_for_thread $ map fst dims) $-    copyDWIM (patElemName pe) (map Imp.vi32 is_for_thread) (Var what) local_is+    copyDWIMFix (patElemName pe) (map Imp.vi32 is_for_thread) (Var what) local_is  compileGroupResult space constants pe (Returns _ what) = do   in_local_memory <- arrayInLocalMemory what@@ -1291,7 +1281,7 @@    if not in_local_memory then     sWhen (kernelLocalThreadId constants .==. 0) $-    copyDWIM (patElemName pe) gids what []+    copyDWIMFix (patElemName pe) gids what []     else       -- If the result of the group is an array in local memory, we       -- store it by collective copying among all the threads of the@@ -1311,22 +1301,16 @@  compileThreadResult space _ pe (Returns _ what) = do   let is = map (Imp.vi32 . fst) $ unSegSpace space-  copyDWIM (patElemName pe) is what []+  copyDWIMFix (patElemName pe) is what []  compileThreadResult _ constants pe (ConcatReturns SplitContiguous _ per_thread_elems what) = do-  dest_loc <- entryArrayLocation <$> lookupArray (patElemName pe)-  let dest_loc_offset = offsetArray dest_loc offset-      dest' = arrayDestination dest_loc_offset-  copyDWIMDest dest' [] (Var what) []+  n <- toExp' int32 . arraySize 0 <$> lookupType what+  copyDWIM (patElemName pe) [DimSlice offset n 1] (Var what) []   where offset = toExp' int32 per_thread_elems * kernelGlobalThreadId constants  compileThreadResult _ constants pe (ConcatReturns (SplitStrided stride) _ _ what) = do-  dest_loc <- entryArrayLocation <$> lookupArray (patElemName pe)-  let dest_loc' = strideArray-                  (offsetArray dest_loc offset) $-                  toExp' int32 stride-      dest' = arrayDestination dest_loc'-  copyDWIMDest dest' [] (Var what) []+  n <- toExp' int32 . arraySize 0 <$> lookupType what+  copyDWIM (patElemName pe) [DimSlice offset n $ toExp' int32 stride] (Var what) []   where offset = kernelGlobalThreadId constants  compileThreadResult _ constants pe (WriteReturns rws _arr dests) = do@@ -1336,7 +1320,7 @@     let condInBounds i rw = 0 .<=. i .&&. i .<. rw         write = foldl (.&&.) (kernelThreadActive constants) $                 zipWith condInBounds is' rws'-    sWhen write $ copyDWIM (patElemName pe) (map (toExp' int32) is) e []+    sWhen write $ copyDWIMFix (patElemName pe) (map (toExp' int32) is) e []  compileThreadResult _ _ _ TileReturns{} =   compilerBugS "compileThreadResult: TileReturns unhandled."
src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs view
@@ -206,10 +206,10 @@   hist_el_size <- dPrimVE "hist_el_size" $ sum $ map slugElAvgSize slugs    hist_C_max <- dPrimVE "hist_C_max" $-    Imp.BinOpExp (SMin Int32) hist_T $ hist_H `quot` hist_k_ct_min+    Imp.BinOpExp (FMin Float64) (r64 hist_T) $ r64 hist_H / hist_k_ct_min    hist_M_min <- dPrimVE "hist_M_min" $-    Imp.BinOpExp (SMax Int32) 1 $ hist_T `quot` hist_C_max+    Imp.BinOpExp (SMax Int32) 1 $ t64 $ r64 hist_T / hist_C_max    -- Querying L2 cache size is not reliable.  Instead we provide a   -- tunable knob with a hopefully sane default.@@ -346,8 +346,7 @@                      -> [SegHistSlug]                      -> KernelBody ExplicitMemory                      -> [[Imp.Exp] -> ImpM ExplicitMemory Imp.KernelOp ()]-                     -> Imp.Exp-                     -> Imp.Exp+                     -> Imp.Exp -> Imp.Exp                      -> ImpM ExplicitMemory Imp.HostOp () histKernelGlobalPass map_pes num_groups group_size space slugs kbody histograms hist_S chk_i = do @@ -390,7 +389,7 @@          sComment "save map-out results" $           forM_ (zip map_pes map_res) $ \(pe, res) ->-          copyDWIM (patElemName pe)+          copyDWIMFix (patElemName pe)           (map (Imp.vi32 . fst) $ unSegSpace space)           (kernelResultSubExp res) [] @@ -416,7 +415,7 @@               dLParams $ lambdaParams lam               sLoopNest shape $ \is -> do                 forM_ (zip vs_params vs') $ \(p, res) ->-                  copyDWIM (paramName p) [] (kernelResultSubExp res) is+                  copyDWIMFix (paramName p) [] (kernelResultSubExp res) is                 do_op (bucket_is ++ is)  @@ -442,23 +441,23 @@     histKernelGlobalPass map_pes num_groups' group_size' space slugs kbody     histograms hist_S chk_i +type InitLocalHistograms = [([VName],+                              (KernelConstants, SubExp) ->+                              InKernelGen ([VName],+                                            [Imp.Exp] -> InKernelGen ()))]+ prepareIntermediateArraysLocal :: VName-                               -> Count NumGroups SubExp+                               -> Count NumGroups Imp.Exp                                -> SegSpace -> [SegHistSlug]-                               -> CallKernelGen-                                  [([VName],-                                    KernelConstants ->-                                    InKernelGen ([VName],-                                                 [Imp.Exp] -> InKernelGen ()))]-prepareIntermediateArraysLocal num_subhistos_per_group num_groups space =-  mapM onOp+                               -> CallKernelGen InitLocalHistograms+prepareIntermediateArraysLocal num_subhistos_per_group groups_per_segment space slugs = do+  num_segments <- dPrimVE "num_segments" $+                  product $ map (toExp' int32 . snd) $ init $ unSegSpace space+  mapM (onOp num_segments) slugs   where-    onOp (SegHistSlug op num_subhistos subhisto_info do_op) = do+    onOp num_segments (SegHistSlug op num_subhistos subhisto_info do_op) = do -      -- For the segmented case we produce a single histogram per group.-      if length (unSegSpace space) > 1-        then num_subhistos <-- 1-        else num_subhistos <-- toExp' int32 (unCount num_groups)+      num_subhistos <-- unCount groups_per_segment * num_segments        emit $ Imp.DebugPrint "Number of subhistograms in global memory" $         Just $ Imp.vi32 num_subhistos@@ -467,35 +466,34 @@         case do_op of           AtomicPrim f -> return $ const $ return f           AtomicCAS f -> return $ const $ return f-          AtomicLocking f -> do-+          AtomicLocking f -> return $ \(constants, hist_H_chk) -> do             let lock_shape =                   Shape $ Var num_subhistos_per_group :                   shapeDims (histShape op) ++-                  [histWidth op]+                  [hist_H_chk]              dims <- mapM toExp $ shapeDims lock_shape -            return $ \constants -> do-              locks <- sAllocArray "locks" int32 lock_shape $ Space "local"+            locks <- sAllocArray "locks" int32 lock_shape $ Space "local" -              sComment "All locks start out unlocked" $-                groupCoverSpace constants dims $ \is ->-                copyDWIM locks is (intConst Int32 0) []+            sComment "All locks start out unlocked" $+              groupCoverSpace constants dims $ \is ->+              copyDWIMFix locks is (intConst Int32 0) [] -              return $ f $ Locking locks 0 1 0 id+            return $ f $ Locking locks 0 1 0 id        -- Initialise local-memory sub-histograms.  These are       -- represented as two-dimensional arrays.-      let init_local_subhistos constants = do+      let init_local_subhistos (constants, hist_H_chk) = do             local_subhistos <-               forM (histType op) $ \t -> do                 let sub_local_shape =-                      Shape [Var num_subhistos_per_group] <> arrayShape t+                      Shape [Var num_subhistos_per_group] <>+                      (arrayShape t `setOuterDim` hist_H_chk)                 sAllocArray "subhistogram_local"                   (elemType t) sub_local_shape (Space "local") -            do_op' <- mk_op constants+            do_op' <- mk_op (constants, hist_H_chk)              return (local_subhistos, do_op' (Space "local") local_subhistos) @@ -506,16 +504,16 @@        return (glob_subhistos, init_local_subhistos) -histKernelLocal :: VName -> Count NumGroups Imp.Exp-                  -> [PatElem ExplicitMemory]-                  -> Count NumGroups SubExp -> Count GroupSize SubExp-                  -> SegSpace-                  -> [SegHistSlug]-                  -> KernelBody ExplicitMemory-                  -> CallKernelGen ()-histKernelLocal num_subhistos_per_group_var groups_per_segment map_pes num_groups group_size space slugs kbody = do-  num_groups' <- traverse toExp num_groups-  group_size' <- traverse toExp group_size+histKernelLocalPass :: VName -> Count NumGroups Imp.Exp+                    -> [PatElem ExplicitMemory]+                    -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp+                    -> SegSpace+                    -> [SegHistSlug]+                    -> KernelBody ExplicitMemory+                    -> InitLocalHistograms -> Imp.Exp -> Imp.Exp+                    -> CallKernelGen ()+histKernelLocalPass num_subhistos_per_group_var groups_per_segment map_pes num_groups group_size space slugs kbody+                    init_histograms hist_S chk_i = do   let (space_is, space_sizes) = unzip $ unSegSpace space       segment_is = init space_is       segment_dims = init space_sizes@@ -524,15 +522,14 @@    segment_size' <- toExp segment_size -  emit $ Imp.DebugPrint "Number of local subhistograms per group" $ Just num_subhistos_per_group--  init_histograms <--    prepareIntermediateArraysLocal num_subhistos_per_group_var num_groups space slugs-   num_segments <- dPrimVE "num_segments" $                   product $ map (toExp' int32) segment_dims -  sKernelThread "seghist_local" num_groups' group_size' (segFlat space) $ \constants ->+  hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w -> do+    w' <- toExp w+    dPrimV "hist_H_chk" $ w' `quotRoundingUp` hist_S++  sKernelThread "seghist_local" num_groups group_size (segFlat space) $ \constants ->     virtualiseGroups constants SegVirt (unCount groups_per_segment * num_segments) $ \group_id_var -> do      let group_id = Imp.vi32 group_id_var@@ -550,10 +547,10 @@     zipWithM_ dPrimV_ segment_is $       unflattenIndex (map (toExp' int32) segment_dims) flat_segment_id -    histograms <- forM init_histograms $-                  \(glob_subhistos, init_local_subhistos) -> do-      (local_subhistos, do_op) <- init_local_subhistos constants-      return (zip glob_subhistos local_subhistos, do_op)+    histograms <- forM (zip init_histograms hist_H_chks) $+                  \((glob_subhistos, init_local_subhistos), hist_H_chk) -> do+      (local_subhistos, do_op) <- init_local_subhistos (constants, Var hist_H_chk)+      return (zip glob_subhistos local_subhistos, hist_H_chk, do_op)      -- Find index of local subhistograms updated by this thread.  We     -- try to ensure, as much as possible, that threads in the same@@ -562,19 +559,14 @@       dPrimVE "thread_local_subhisto_i" $       kernelLocalThreadId constants `rem` num_subhistos_per_group -    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--    let onSlugs f = forM_ (zip slugs histograms) $ \(slug, (dests, _)) -> do-          let histo_dims = map (toExp' int32) $ histWidth (slugOp slug) :+    let onSlugs f = forM_ (zip slugs histograms) $ \(slug, (dests, hist_H_chk, _)) -> do+          let histo_dims = fmap (toExp' int32) $ Var hist_H_chk :                            shapeDims (histShape (slugOp slug))           histo_size <- dPrimVE "histo_size" $ product histo_dims-          f slug dests histo_dims histo_size+          f slug dests (Imp.vi32 hist_H_chk) histo_dims histo_size      let onAllHistograms f =-          onSlugs $ \slug dests histo_dims histo_size -> do+          onSlugs $ \slug dests hist_H_chk histo_dims histo_size -> do             let group_hists_size = num_subhistos_per_group * histo_size             init_per_thread <- dPrimVE "init_per_thread" $                                group_hists_size `quotRoundingUp`@@ -590,23 +582,25 @@                               num_subhistos_per_group * histo_size * gid_in_segment + j                    local_subhisto_i <- dPrimVE "local_subhisto_i" $ j `quot` histo_size-                  let bucket_is = unflattenIndex histo_dims $ j `rem` histo_size+                  let local_bucket_is = unflattenIndex histo_dims $ j `rem` histo_size+                      global_bucket_is = head local_bucket_is + chk_i * hist_H_chk :+                                         tail local_bucket_is                   global_subhisto_i <- dPrimVE "global_subhisto_i" $ j_offset `quot` histo_size                    sWhen (j .<. group_hists_size) $                     f dest_local dest_global (slugOp slug) ne                     local_subhisto_i global_subhisto_i-                    bucket_is+                    local_bucket_is global_bucket_is      sComment "initialize histograms in local memory" $-      onAllHistograms $ \dest_local dest_global op ne local_subhisto_i global_subhisto_i bucket_is ->+      onAllHistograms $ \dest_local dest_global op ne local_subhisto_i global_subhisto_i local_bucket_is global_bucket_is ->       sComment "First subhistogram is initialised from global memory; others with neutral element." $ do-      let global_is = map Imp.vi32 segment_is ++ [0] ++ bucket_is-          local_is = local_subhisto_i : bucket_is+      let global_is = map Imp.vi32 segment_is ++ [0] ++ global_bucket_is+          local_is = local_subhisto_i : local_bucket_is       sIf (global_subhisto_i .==. 0)-        (copyDWIM dest_local local_is (Var dest_global) global_is)+        (copyDWIMFix dest_local local_is (Var dest_global) global_is)         (sLoopNest (histShape op) $ \is ->-            copyDWIM dest_local (local_is++is) ne [])+            copyDWIMFix dest_local (local_is++is) ne [])      sOp Imp.LocalBarrier @@ -614,23 +608,33 @@       dPrimV_ i_in_segment ie        -- We execute the bucket function once and update each histogram-      -- serially.  This also involves writing to the mapout arrays.+      -- serially.  This also involves writing to the mapout arrays if+      -- this is the first chunk.        compileStms mempty (kernelBodyStms kbody) $ do -        sComment "save map-out results" $+        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" $           forM_ (zip map_pes map_res) $ \(pe, se) ->-          copyDWIM (patElemName pe)+          copyDWIMFix (patElemName pe)           (map Imp.vi32 space_is) se []          forM_ (zip4 (map slugOp slugs) histograms buckets (perOp vs)) $           \(HistOp dest_w _ _ _ shape lam,-            (_, do_op), bucket, vs') -> do+            (_, hist_H_chk, do_op), bucket, vs') -> do -            let bucket' = toExp' int32 bucket+            let chk_beg = chk_i * Imp.vi32 hist_H_chk+                bucket' = toExp' int32 bucket                 dest_w' = toExp' int32 dest_w-                bucket_in_bounds = 0 .<=. bucket' .&&. bucket' .<. dest_w'-                bucket_is = [thread_local_subhisto_i, bucket']+                bucket_in_bounds = bucket' .<. dest_w' .&&.+                                   chk_beg .<=. bucket' .&&.+                                   bucket' .<. (chk_beg + Imp.vi32 hist_H_chk)+                bucket_is = [thread_local_subhisto_i, bucket' - chk_beg]                 vs_params = takeLast (length vs') $ lambdaParams lam              sComment "perform atomic updates" $@@ -638,50 +642,93 @@               dLParams $ lambdaParams lam               sLoopNest shape $ \is -> do                 forM_ (zip vs_params vs') $ \(p, v) ->-                  copyDWIM (paramName p) [] v is+                  copyDWIMFix (paramName p) [] v is                 do_op (bucket_is ++ is) -    sOp Imp.LocalBarrier+    sOp Imp.ErrorSync     sOp Imp.GlobalBarrier      sComment "Compact the multiple local memory subhistograms to result in global memory" $-      onSlugs $ \slug dests histo_dims histo_size -> do+      onSlugs $ \slug dests hist_H_chk histo_dims histo_size -> do       bins_per_thread <- dPrimVE "init_per_thread" $                          histo_size `quotRoundingUp` kernelGroupSize constants +      trunc_H <- dPrimV "trunc_H" $+                 Imp.BinOpExp (SMin Int32) hist_H_chk $+                 toExp' int32 (histWidth (slugOp slug)) -+                 chk_i * head histo_dims+      let trunc_histo_dims = map (toExp' int32) $ Var trunc_H :+                             shapeDims (histShape (slugOp slug))+      trunc_histo_size <- dPrimVE "histo_size" $ product trunc_histo_dims+       sFor "local_i" bins_per_thread $ \i -> do         j <- dPrimVE "j" $              i * kernelGroupSize constants + kernelLocalThreadId constants-        sWhen (j .<. histo_size) $ do+        sWhen (j .<. trunc_histo_size) $ do           -- We are responsible for compacting the flat bin 'j', which           -- we immediately unflatten.-          let bucket_is = unflattenIndex histo_dims j+          let local_bucket_is = unflattenIndex histo_dims j+              global_bucket_is = head local_bucket_is + chk_i * hist_H_chk :+                                 tail local_bucket_is           dLParams $ lambdaParams $ histOp $ slugOp slug-          let (xparams, yparams) = splitAt (length local_dests) $+          let (global_dests, local_dests) = unzip dests+              (xparams, yparams) = splitAt (length local_dests) $                                    lambdaParams $ histOp $ slugOp slug-              (global_dests, local_dests) = unzip dests            sComment "Read values from subhistogram 0." $             forM_ (zip xparams local_dests) $ \(xp, subhisto) ->-            copyDWIM+            copyDWIMFix             (paramName xp) []-            (Var subhisto) (0:bucket_is)+            (Var subhisto) (0:local_bucket_is)            sComment "Accumulate based on values in other subhistograms." $             sFor "subhisto_id" (num_subhistos_per_group - 1) $ \subhisto_id -> do               forM_ (zip yparams local_dests) $ \(yp, subhisto) ->-                copyDWIM+                copyDWIMFix                 (paramName yp) []-                (Var subhisto) (subhisto_id + 1 : bucket_is)+                (Var subhisto) (subhisto_id + 1 : local_bucket_is)               compileBody' xparams $ lambdaBody $ histOp $ slugOp slug            sComment "Put final bucket value in global memory." $ do-            let global_is = map Imp.vi32 segment_is ++-                            [group_id `rem` unCount groups_per_segment] ++-                            bucket_is+            let global_is =+                  map Imp.vi32 segment_is +++                  [group_id `rem` unCount groups_per_segment] +++                  global_bucket_is             forM_ (zip xparams global_dests) $ \(xp, global_dest) ->-              copyDWIM global_dest global_is (Var $ paramName xp) []+              copyDWIMFix global_dest global_is (Var $ paramName xp) [] +histKernelLocal :: VName -> Count NumGroups Imp.Exp+                -> [PatElem ExplicitMemory]+                -> Count NumGroups SubExp -> Count GroupSize SubExp+                -> SegSpace+                -> Imp.Exp+                -> [SegHistSlug]+                -> KernelBody ExplicitMemory+                -> CallKernelGen ()+histKernelLocal num_subhistos_per_group_var groups_per_segment map_pes num_groups group_size space hist_S slugs kbody = do+  num_groups' <- traverse toExp num_groups+  group_size' <- traverse toExp group_size+  let num_subhistos_per_group = Imp.var num_subhistos_per_group_var int32++  emit $ Imp.DebugPrint "Number of local subhistograms per group" $ Just num_subhistos_per_group++  init_histograms <-+    prepareIntermediateArraysLocal num_subhistos_per_group_var groups_per_segment space slugs++  sFor "chk_i" hist_S $ \chk_i ->+    histKernelLocalPass+    num_subhistos_per_group_var groups_per_segment map_pes num_groups' group_size' space slugs kbody+    init_histograms hist_S chk_i++-- | The maximum number of passes we are willing to accept for this+-- kind of atomic update.+slugMaxLocalMemPasses :: SegHistSlug -> Int+slugMaxLocalMemPasses slug =+  case slugAtomicUpdate slug of+    AtomicPrim _ -> 2+    AtomicCAS _  -> 4+    AtomicLocking _ -> 5+ localMemoryCase :: [PatElem ExplicitMemory]                 -> Imp.Exp                 -> SegSpace@@ -707,6 +754,8 @@    let r64 = ConvOpExp (SIToFP Int32 Float64)       t64 = ConvOpExp (FPToSI Float64 Int32)+      i32_to_i64 = ConvOpExp (SExt Int32 Int64)+      i64_to_i32 = ConvOpExp (SExt Int64 Int32)       f64ceil x = t64 $ FunExp "round64" [x] $ FloatType Float64    -- M approximation.@@ -764,8 +813,8 @@   -- Minimal sequential chunking factor.   let q_small = 2 -  hist_Nout <- dPrimVE "hist_Nout" $-               product $ map (toExp' int32) segment_dims+  -- The number of segments/histograms produced..+  hist_Nout <- dPrimVE "hist_Nout" $ product $ map (toExp' int32) segment_dims    hist_Nin <- dPrimVE "hist_Nin" $ toExp' int32 $ last space_sizes @@ -774,9 +823,11 @@     if segmented then do        hist_T_hist_min <- dPrimVE "hist_T_hist_min" $-                         Imp.BinOpExp (SMin Int32) (hist_Nin * hist_Nout) hist_T+                         i64_to_i32 $+                         Imp.BinOpExp (SMin Int64)+                         (i32_to_i64 hist_Nin * i32_to_i64 hist_Nout) (i32_to_i64 hist_T)                          `quotRoundingUp`-                         hist_Nout+                         i32_to_i64 hist_Nout        -- Number of groups, rounded up.       let r = hist_T_hist_min `quotRoundingUp` hist_B@@ -809,19 +860,29 @@   emit $ Imp.DebugPrint "local memory needed" $     Just $ hist_H * hist_el_size * Imp.vi32 hist_M +  -- local_mem_needed is what we need to keep a single bucket in local+  -- memory - this is an absolute minimum.  We can fit anything else+  -- by doing multiple passes, although more than a few is+  -- (heuristically) not efficient.+  local_mem_needed <- dPrimVE "local_mem_needed" $ hist_el_size * Imp.vi32 hist_M+  hist_S <- dPrimVE "hist_S" $ (hist_H * local_mem_needed) `quotRoundingUp` Imp.vi32 hist_L+  let max_S = case bodyPassage kbody of+                MustBeSinglePass -> 1+                MayBeMultiPass -> fromIntegral $ maximum $ map slugMaxLocalMemPasses slugs+   -- We only use local memory if the number of updates per histogram   -- at least matches the histogram size, as otherwise it is not   -- asymptotically efficient.  This mostly matters for the segmented   -- case.   let pick_local =         hist_Nin .>=. hist_H-        .&&. (hist_H * hist_el_size * Imp.vi32 hist_M-              .<=. Imp.vi32 hist_L)+        .&&. (local_mem_needed .<=. Imp.vi32 hist_L)+        .&&. (hist_S .<=. max_S)         .&&. hist_C .<=. hist_B         .&&. Imp.vi32 hist_M .>. 0        groups_per_segment-        | segmented = 1+        | segmented = num_groups' `quotRoundingUp` Imp.Count hist_Nout         | otherwise = num_groups'        run = do@@ -829,8 +890,11 @@         emit $ Imp.DebugPrint "Histogram size (H)" $ Just hist_H         emit $ Imp.DebugPrint "Multiplication degree (M)" $ Just $ Imp.vi32 hist_M         emit $ Imp.DebugPrint "Cooperation level (C)" $ Just hist_C+        emit $ Imp.DebugPrint "Number of chunks (S)" $ Just hist_S+        when segmented $+          emit $ Imp.DebugPrint "Groups per segment" $ Just $ unCount groups_per_segment         histKernelLocal hist_M groups_per_segment map_pes-          num_groups group_size space slugs kbody+          num_groups group_size space hist_S slugs kbody    return (pick_local, run) @@ -858,43 +922,45 @@   h <- dPrimVE "h" $ Imp.unCount $ sum op_hs   seg_h <- dPrimVE "seg_h" $ Imp.unCount $ sum op_seg_hs -  -- Maximum group size (or actual, in this case).-  let hist_B = unCount group_size'+  -- Check for emptyness to avoid division-by-zero.+  sUnless (seg_h .==. 0) $ do -  -- Size of a histogram.-  hist_H <- dPrimVE "hist_H" $ sum $ map (toExp' int32 . histWidth) ops+    -- Maximum group size (or actual, in this case).+    let hist_B = unCount group_size' -  -- Size of a single histogram element.  Actually the weighted-  -- average of histogram elements in cases where we have more than-  -- one histogram operation, plus any locks.-  let lockSize slug = case slugAtomicUpdate slug of-                        AtomicLocking{} -> Just $ primByteSize int32-                        _               -> Nothing-  hist_el_size <- dPrimVE "hist_el_size" $ foldl' (+) (h `quotRoundingUp` hist_H) $-                  mapMaybe lockSize slugs+    -- Size of a histogram.+    hist_H <- dPrimVE "hist_H" $ sum $ map (toExp' int32 . histWidth) ops -  -- Input elements contributing to each histogram.-  hist_N <- dPrimVE "hist_N" segment_size+    -- Size of a single histogram element.  Actually the weighted+    -- average of histogram elements in cases where we have more than+    -- one histogram operation, plus any locks.+    let lockSize slug = case slugAtomicUpdate slug of+                          AtomicLocking{} -> Just $ primByteSize int32+                          _               -> Nothing+    hist_el_size <- dPrimVE "hist_el_size" $ foldl' (+) (h `quotRoundingUp` hist_H) $+                    mapMaybe lockSize slugs -  -- Compute RF as the average RF over all the histograms.-  hist_RF <- dPrimVE "hist_RF" $-             sum (map (toExp' int32. histRaceFactor . slugOp) slugs)-             `quot`-             genericLength slugs+    -- Input elements contributing to each histogram.+    hist_N <- dPrimVE "hist_N" segment_size -  -- Check for emptyness to avoid division-by-zero.-  sUnless (seg_h .==. 0) $ do+    -- Compute RF as the average RF over all the histograms.+    hist_RF <- dPrimVE "hist_RF" $+               sum (map (toExp' int32. histRaceFactor . slugOp) slugs)+               `quot`+               genericLength slugs      let hist_T = unCount num_groups' * unCount group_size'     emit $ Imp.DebugPrint "\n# SegHist" Nothing     emit $ Imp.DebugPrint "Number of threads (T)" $ Just hist_T-    emit $ Imp.DebugPrint "Memory per set of subhistograms per segment" $ Just h-    emit $ Imp.DebugPrint "Memory per set of subhistograms times segments" $ Just seg_h-    emit $ Imp.DebugPrint "Input elements per histogram (N)" $ Just hist_N     emit $ Imp.DebugPrint "Desired group size (B)" $ Just hist_B     emit $ Imp.DebugPrint "Histogram size (H)" $ Just hist_H+    emit $ Imp.DebugPrint "Input elements per histogram (N)" $ Just hist_N+    emit $ Imp.DebugPrint "Number of segments" $+      Just $ product $ map (toExp' int32 . snd) segment_dims     emit $ Imp.DebugPrint "Histogram element size (el_size)" $ Just hist_el_size     emit $ Imp.DebugPrint "Race factor (RF)" $ Just hist_RF+    emit $ Imp.DebugPrint "Memory per set of subhistograms per segment" $ Just h+    emit $ Imp.DebugPrint "Memory per set of subhistograms times segments" $ Just seg_h      (use_local_memory, run_in_local_memory) <-       localMemoryCase map_pes hist_T space hist_H hist_el_size hist_N hist_RF slugs kbody
src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs view
@@ -21,9 +21,6 @@               -> KernelBody ExplicitMemory               -> CallKernelGen () -compileSegMap _ SegThreadScalar{} _ _ =-  fail "compileSegMap: SegThreadScalar cannot be compiled at top level."- compileSegMap pat lvl space kbody = do   let (is, dims) = unzip $ unSegSpace space   dims' <- mapM toExp dims@@ -32,8 +29,6 @@   group_size' <- traverse toExp $ segGroupSize lvl    case lvl of-    SegThreadScalar{} ->-      fail "compileSegMap: SegThreadScalar cannot be compiled at top level."      SegThread{} ->       sKernelThread "segmap" num_groups' group_size' (segFlat space) $ \constants -> do
src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs view
@@ -257,21 +257,21 @@       let out_of_bounds =             forM_ (zip reds reds_arrs) $ \(SegRedOp _ _ nes _, red_arrs) ->             forM_ (zip red_arrs nes) $ \(arr, ne) ->-            copyDWIM arr [ltid] ne []+            copyDWIMFix arr [ltid] ne []            in_bounds =             body constants $ \red_res ->             sComment "save results to be reduced" $ do             let red_dests = zip (concat reds_arrs) $ repeat [ltid]             forM_ (zip red_dests red_res) $ \((d,d_is), (res, res_is)) ->-              copyDWIM d d_is res res_is+              copyDWIMFix d d_is res res_is        sComment "apply map function if in bounds" $         sIf (segment_size .>. 0 .&&.              isActive (init $ zip gtids dims) .&&.              ltid .<. segment_size * segments_per_group) in_bounds out_of_bounds -      sOp Imp.LocalBarrier+      sOp Imp.ErrorSync -- Also implicitly barrier.        let crossesSegment from to = (to-from) .>. (to `rem` segment_size)       sWhen (segment_size .>. 0) $@@ -288,7 +288,7 @@         -- Figure out which segment result this thread should write...         let flat_segment_index = group_id' * segments_per_group + ltid             gtids' = unflattenIndex (init dims') flat_segment_index-        copyDWIM (patElemName pe) gtids'+        copyDWIMFix (patElemName pe) gtids'                         (Var arr) [(ltid+1) * segment_size_nonzero - 1]        -- Finally another barrier, because we will be writing to the@@ -398,7 +398,7 @@             forM_ (zip slugs segred_pes) $ \(slug, pes) ->             sWhen (local_tid .==. 0) $               forM_ (zip pes (slugAccs slug)) $ \(v, (acc, acc_is)) ->-              copyDWIM (patElemName v) (map (`Imp.var` int32) segment_gtids) (Var acc) acc_is+              copyDWIMFix (patElemName v) (map (`Imp.var` int32) segment_gtids) (Var acc) acc_is        sIf (groups_per_segment .==. 1) one_group_per_segment multiple_groups_per_segment @@ -483,7 +483,7 @@     forM_ slugs $ \slug ->     forM_ (zip (slugAccs slug) (slugNeutral slug)) $ \((acc, acc_is), ne) ->     sLoopNest (slugShape slug) $ \vec_is ->-    copyDWIM acc (acc_is++vec_is) ne []+    copyDWIMFix acc (acc_is++vec_is) ne []    slugs_op_renamed <- mapM (renameLambda . segRedLambda . slugOp) slugs @@ -492,13 +492,13 @@         sLoopNest (slugShape slug) $ \vec_is -> do           comment "to reduce current chunk, first store our result in memory" $ do             forM_ (zip (slugParams slug) (slugAccs slug)) $ \(p, (acc, acc_is)) ->-              copyDWIM (paramName p) [] (Var acc) (acc_is++vec_is)+              copyDWIMFix (paramName p) [] (Var acc) (acc_is++vec_is)              forM_ (zip (slugArrs slug) (slugParams slug)) $ \(arr, p) ->               when (primType $ paramType p) $-              copyDWIM arr [local_tid] (Var $ paramName p) []+              copyDWIMFix arr [local_tid] (Var $ paramName p) [] -          sOp Imp.LocalBarrier+          sOp Imp.ErrorSync -- Also implicitly barrier.            groupReduce constants (kernelGroupSize constants) slug_op_renamed (slugArrs slug) @@ -507,7 +507,7 @@           sComment "first thread saves the result in accumulator" $             sWhen (local_tid .==. 0) $             forM_ (zip (slugAccs slug) (lambdaParams slug_op_renamed)) $ \((acc, acc_is), p) ->-            copyDWIM acc (acc_is++vec_is) (Var $ paramName p) []+            copyDWIMFix acc (acc_is++vec_is) (Var $ paramName p) []    -- If this is a non-commutative reduction, each thread must run the   -- loop the same number of iterations, because we will be performing@@ -540,17 +540,17 @@         sLoopNest (slugShape slug) $ \vec_is -> do         sComment "load accumulator" $           forM_ (zip (accParams slug) (slugAccs slug)) $ \(p, (acc, acc_is)) ->-          copyDWIM (paramName p) [] (Var acc) (acc_is ++ vec_is)+          copyDWIMFix (paramName p) [] (Var acc) (acc_is ++ vec_is)         sComment "load new values" $           forM_ (zip (nextParams slug) red_res) $ \(p, (res, res_is)) ->-          copyDWIM (paramName p) [] res (res_is ++ vec_is)+          copyDWIMFix (paramName p) [] res (res_is ++ vec_is)         sComment "apply reduction operator" $           compileStms mempty (bodyStms $ slugBody slug) $           sComment "store in accumulator" $           forM_ (zip                   (slugAccs slug)                   (bodyResult $ slugBody slug)) $ \((acc, acc_is), se) ->-          copyDWIM acc (acc_is ++ vec_is) se []+          copyDWIMFix acc (acc_is ++ vec_is) se []      case comm of       Noncommutative -> do@@ -560,7 +560,7 @@                 forM_ slugs $ \slug ->                 forM_ (zip (slugAccs slug) (slugNeutral slug)) $ \((acc, acc_is), ne) ->                 sLoopNest (slugShape slug) $ \vec_is ->-                copyDWIM acc (acc_is++vec_is) ne []+                copyDWIMFix acc (acc_is++vec_is) ne []           sUnless (local_tid .==. 0) reset_to_neutral       _ -> return () @@ -583,7 +583,7 @@     Noncommutative ->       forM_ slugs $ \slug ->       forM_ (zip (accParams slug) (slugAccs slug)) $ \(p, (acc, acc_is)) ->-      copyDWIM (paramName p) [] (Var acc) acc_is+      copyDWIMFix (paramName p) [] (Var acc) acc_is     _ -> doTheReduction    return slugs_op_renamed@@ -613,7 +613,7 @@   comment "first thread in group saves group result to global memory" $     sWhen (local_tid .==. 0) $ do     forM_ (take (length nes) $ zip group_res_arrs (slugAccs slug)) $ \(v, (acc, acc_is)) ->-      copyDWIM v [0, group_id] (Var acc) acc_is+      copyDWIMFix v [0, group_id] (Var acc) acc_is     sOp Imp.MemFenceGlobal     -- Increment the counter, thus stating that our result is     -- available.@@ -626,7 +626,7 @@   sOp Imp.GlobalBarrier    is_last_group <- dPrim "is_last_group" Bool-  copyDWIM is_last_group [] (Var sync_arr) [0]+  copyDWIMFix is_last_group [] (Var sync_arr) [0]   sWhen (Imp.var is_last_group Bool) $ do     -- The final group has written its result (and it was     -- us!), so read in all the group results and perform the@@ -642,14 +642,14 @@         forM_ (zip4 red_acc_params red_arrs nes group_res_arrs) $         \(p, arr, ne, group_res_arr) -> do           let load_group_result =-                copyDWIM (paramName p) []+                copyDWIMFix (paramName p) []                 (Var group_res_arr) ([0, first_group_for_segment + local_tid] ++ vec_is)               load_neutral_element =-                copyDWIM (paramName p) [] ne []+                copyDWIMFix (paramName p) [] ne []           sIf (local_tid .<. groups_per_segment)             load_group_result load_neutral_element           when (primType $ paramType p) $-            copyDWIM arr [local_tid] (Var $ paramName p) []+            copyDWIMFix arr [local_tid] (Var $ paramName p) []        sOp Imp.LocalBarrier @@ -659,4 +659,4 @@         sComment "and back to memory with the final result" $           sWhen (local_tid .==. 0) $           forM_ (zip segred_pes $ lambdaParams red_op_renamed) $ \(pe, p) ->-          copyDWIM (patElemName pe) (segment_gtids++vec_is) (Var $ paramName p) []+          copyDWIMFix (patElemName pe) (segment_gtids++vec_is) (Var $ paramName p) []
src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs view
@@ -75,7 +75,7 @@           splitAt (length nes) $ lambdaParams scan_op      forM_ (zip scan_x_params nes) $ \(p, ne) ->-      copyDWIM (paramName p) [] ne []+      copyDWIMFix (paramName p) [] ne []      sFor "j" elems_per_thread $ \j -> do       chunk_offset <- dPrimV "chunk_offset" $@@ -92,13 +92,13 @@             let (scan_res, map_res) = splitAt (length nes) $ kernelBodyResult kbody             sComment "write to-scan values to parameters" $               forM_ (zip scan_y_params scan_res) $ \(p, se) ->-              copyDWIM (paramName p) [] (kernelResultSubExp se) []+              copyDWIMFix (paramName p) [] (kernelResultSubExp se) []             sComment "write mapped values results to global memory" $               forM_ (zip (drop (length nes) pes) map_res) $ \(pe, se) ->-              copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids)+              copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)               (kernelResultSubExp se) []           when_out_of_bounds = forM_ (zip scan_y_params nes) $ \(p, ne) ->-            copyDWIM (paramName p) [] ne []+            copyDWIMFix (paramName p) [] ne []        sComment "threads in bounds read input; others get neutral element" $         sIf in_bounds when_in_bounds when_out_of_bounds@@ -106,7 +106,7 @@       sComment "combine with carry and write to local memory" $         compileStms mempty (bodyStms $ lambdaBody scan_op) $         forM_ (zip local_arrs $ bodyResult $ lambdaBody scan_op) $ \(arr, se) ->-          copyDWIM arr [kernelLocalThreadId constants] se []+          copyDWIMFix arr [kernelLocalThreadId constants] se []        let crossesSegment' = do             f <- crossesSegment@@ -115,22 +115,24 @@                   to' = to + Imp.var chunk_offset int32               in f from' to' +      sOp Imp.ErrorSync -- Also implicitly barrier.+       groupScan constants crossesSegment'         (kernelGroupSize constants) scan_op_renamed local_arrs        sComment "threads in bounds write partial scan result" $         sWhen in_bounds $ forM_ (zip pes local_arrs) $ \(pe, arr) ->-        copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids)+        copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)         (Var arr) [kernelLocalThreadId constants]        sOp Imp.LocalBarrier        let load_carry =             forM_ (zip local_arrs scan_x_params) $ \(arr, p) ->-            copyDWIM (paramName p) [] (Var arr) [kernelGroupSize constants - 1]+            copyDWIMFix (paramName p) [] (Var arr) [kernelGroupSize constants - 1]           load_neutral =             forM_ (zip nes scan_x_params) $ \(ne, p) ->-            copyDWIM (paramName p) [] ne []+            copyDWIMFix (paramName p) [] ne []        sComment "first thread reads last element as carry-in for next iteration" $         sWhen (kernelLocalThreadId constants .==. 0) $@@ -173,10 +175,10 @@     let in_bounds =           foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'         when_in_bounds = forM_ (zip local_arrs pes) $ \(arr, pe) ->-          copyDWIM arr [kernelLocalThreadId constants]+          copyDWIMFix arr [kernelLocalThreadId constants]           (Var $ patElemName pe) $ map (`Imp.var` int32) gtids         when_out_of_bounds = forM_ (zip local_arrs nes) $ \(arr, ne) ->-          copyDWIM arr [kernelLocalThreadId constants] ne []+          copyDWIMFix arr [kernelLocalThreadId constants] ne []      sComment "threads in bound read carries; others get neutral element" $       sIf in_bounds when_in_bounds when_out_of_bounds@@ -186,7 +188,7 @@      sComment "threads in bounds write scanned carries" $       sWhen in_bounds $ forM_ (zip pes local_arrs) $ \(pe, arr) ->-      copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids)+      copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)       (Var arr) [kernelLocalThreadId constants]  scanStage3 :: Pattern ExplicitMemory@@ -226,12 +228,12 @@       let (scan_x_params, scan_y_params) =             splitAt (length nes) $ lambdaParams scan_op       forM_ (zip scan_x_params pes) $ \(p, pe) ->-        copyDWIM (paramName p) [] (Var $ patElemName pe) carry_in_idx+        copyDWIMFix (paramName p) [] (Var $ patElemName pe) carry_in_idx       forM_ (zip scan_y_params pes) $ \(p, pe) ->-        copyDWIM (paramName p) [] (Var $ patElemName pe) $ map (`Imp.var` int32) gtids+        copyDWIMFix (paramName p) [] (Var $ patElemName pe) $ map (`Imp.var` int32) gtids       compileBody' scan_x_params $ lambdaBody scan_op       forM_ (zip scan_x_params pes) $ \(p, pe) ->-        copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids) (Var $ paramName p) []+        copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids) (Var $ paramName p) []  -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels.
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -10,7 +10,6 @@  import Control.Monad.State import Control.Monad.Identity-import Control.Monad.Writer import Control.Monad.Reader import Data.Maybe import qualified Data.Set as S@@ -28,7 +27,6 @@ import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) import qualified Futhark.CodeGen.ImpCode.OpenCL as ImpOpenCL import Futhark.MonadFreshNames-import Futhark.Representation.ExplicitMemory (allScalarMemory) import Futhark.Util (zEncodeString)  kernelsToCUDA, kernelsToOpenCL :: ImpKernels.Program@@ -41,17 +39,16 @@                  -> ImpKernels.Program                  -> Either InternalError ImpOpenCL.Program translateKernels target (ImpKernels.Functions funs) = do-  (prog', ToOpenCL extra_funs kernels requirements sizes) <--    runWriterT $ fmap Functions $ forM funs $ \(fname, fun) ->+  (prog', ToOpenCL kernels used_types sizes failures) <-+    flip runStateT initialOpenCL $ fmap Functions $ forM funs $ \(fname, fun) ->     (fname,) <$> runReaderT (traverse (onHostOp target) fun) fname-  let kernel_names = M.keys kernels-      opencl_code = openClCode $ M.elems kernels-      opencl_prelude = pretty $ genPrelude target requirements-  return $ ImpOpenCL.Program opencl_code opencl_prelude kernel_names-    (S.toList $ openclUsedTypes requirements) (cleanSizes sizes) $-    ImpOpenCL.Functions (M.toList extra_funs) <> prog'+  let kernels' = M.map fst kernels+      opencl_code = openClCode $ map snd $ M.elems kernels+      opencl_prelude = pretty $ genPrelude target used_types+  return $ ImpOpenCL.Program opencl_code opencl_prelude kernels'+    (S.toList used_types) (cleanSizes sizes) failures prog'   where genPrelude TargetOpenCL = genOpenClPrelude-        genPrelude TargetCUDA = genCUDAPrelude+        genPrelude TargetCUDA = const genCUDAPrelude  -- | Due to simplifications after kernel extraction, some threshold -- parameters may contain KernelPaths that reference threshold@@ -76,48 +73,44 @@ -- In-kernel name and per-workgroup size in bytes. type LocalMemoryUse = (VName, Count Bytes Exp) -newtype KernelRequirements =-  KernelRequirements { kernelLocalMemory :: [LocalMemoryUse] }--instance Semigroup KernelRequirements where-  KernelRequirements lm1 <> KernelRequirements lm2 =-    KernelRequirements (lm1<>lm2)--instance Monoid KernelRequirements where-  mempty = KernelRequirements mempty--newtype OpenClRequirements =-  OpenClRequirements { openclUsedTypes :: S.Set PrimType }+data KernelState =+  KernelState { kernelLocalMemory :: [LocalMemoryUse]+              , kernelFailures :: [FailureMsg]+              , kernelNextSync :: Int+              , kernelSyncPending :: Bool+                -- ^ Has a potential failure occurred sine the last+                -- ErrorSync?+              , kernelHasBarriers :: Bool+              } -instance Semigroup OpenClRequirements where-  OpenClRequirements ts1 <> OpenClRequirements ts2 =-    OpenClRequirements (ts1 <> ts2)+newKernelState :: [FailureMsg] -> KernelState+newKernelState failures = KernelState mempty failures 0 False False -instance Monoid OpenClRequirements where-  mempty = OpenClRequirements mempty+errorLabel :: KernelState -> String+errorLabel = ("error_"++) . show . kernelNextSync -data ToOpenCL = ToOpenCL { clExtraFuns :: M.Map Name ImpOpenCL.Function-                         , clKernels :: M.Map KernelName C.Func-                         , clRequirements :: OpenClRequirements+data ToOpenCL = ToOpenCL { clKernels :: M.Map KernelName (Safety, C.Func)+                         , clUsedTypes :: S.Set PrimType                          , clSizes :: M.Map Name SizeClass+                         , clFailures :: [FailureMsg]                          } -instance Semigroup ToOpenCL where-  ToOpenCL f1 k1 r1 sz1 <> ToOpenCL f2 k2 r2 sz2 =-    ToOpenCL (f1<>f2) (k1<>k2) (r1<>r2) (sz1<>sz2)+initialOpenCL :: ToOpenCL+initialOpenCL = ToOpenCL mempty mempty mempty mempty -instance Monoid ToOpenCL where-  mempty = ToOpenCL mempty mempty mempty mempty+type OnKernelM = ReaderT Name (StateT ToOpenCL (Either InternalError)) -type OnKernelM = ReaderT Name (WriterT ToOpenCL (Either InternalError))+addSize :: Name -> SizeClass -> OnKernelM ()+addSize key sclass =+  modify $ \s -> s { clSizes = M.insert key sclass $ clSizes s }  onHostOp :: KernelTarget -> HostOp -> OnKernelM OpenCL onHostOp target (CallKernel k) = onKernel target k onHostOp _ (ImpKernels.GetSize v key size_class) = do-  tell mempty { clSizes = M.singleton key size_class }+  addSize key size_class   return $ ImpOpenCL.GetSize v key onHostOp _ (ImpKernels.CmpSizeLe v key size_class x) = do-  tell mempty { clSizes = M.singleton key size_class }+  addSize key size_class   return $ ImpOpenCL.CmpSizeLe v key x onHostOp _ (ImpKernels.GetSizeMax v size_class) =   return $ ImpOpenCL.GetSizeMax v size_class@@ -125,17 +118,20 @@ onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL  onKernel target kernel = do-  let (kernel_body, requirements) =-        GenericC.runCompilerM mempty inKernelOperations blankNameSource mempty $+  failures <- gets clFailures+  let (kernel_body, cstate) =+        GenericC.runCompilerM mempty (inKernelOperations (kernelBody kernel))+        blankNameSource+        (newKernelState failures) $         GenericC.blockScope $ GenericC.compileCode $ kernelBody kernel+      kstate = GenericC.compUserState cstate        use_params = mapMaybe useAsParam $ kernelUses kernel        (local_memory_args, local_memory_params, local_memory_init) =         unzip3 $         flip evalState (blankNameSource :: VNameSource) $-        mapM (prepareLocalMemory target) $ kernelLocalMemory $-        GenericC.compUserState requirements+        mapM (prepareLocalMemory target) $ kernelLocalMemory kstate        -- CUDA has very strict restrictions on the number of blocks       -- permitted along the 'y' and 'z' dimensions of the grid@@ -158,22 +154,70 @@                  [C.citem|const int block_dim1 = 1;|],                  [C.citem|const int block_dim2 = 2;|]]) -      params = perm_params ++ catMaybes local_memory_params ++ use_params+      (const_defs, const_undefs) = unzip $ mapMaybe constDef $ kernelUses kernel -      const_defs = mapMaybe constDef $ kernelUses kernel+  let (safety, error_init)+        | length (kernelFailures kstate) == length failures =+            if kernelFailureTolerant kernel+            then (SafetyNone, [])+            else -- No possible failures in this kernel, so if we make+                 -- it past an initial check, then we are good to go.+                 (SafetyCheap,+                  [C.citems|if (*global_failure >= 0) { return; }|]) -  tell mempty { clExtraFuns = mempty-              , clKernels = M.singleton name-                            [C.cfun|__kernel void $id:name ($params:params) {-                                $items:const_defs-                                $items:block_dim_init-                                $items:local_memory_init-                                $items:kernel_body-                                }|]-              , clRequirements = OpenClRequirements (typesInKernel kernel)-              }+        | otherwise =+            if not (kernelHasBarriers kstate)+            then (SafetyFull,+                  [C.citems|if (*global_failure >= 0) { return; }|])+            else (SafetyFull,+                  [C.citems|+                     volatile __local bool local_failure;+                     if (failure_is_an_option) {+                       if (get_local_id(0) == 0) {+                         local_failure = *global_failure >= 0;+                       }+                       barrier(CLK_LOCAL_MEM_FENCE);+                       if (local_failure) { return; }+                     } else {+                       local_failure = false;+                     }+                     barrier(CLK_LOCAL_MEM_FENCE);+                  |]) -  return $ LaunchKernel name (catMaybes local_memory_args ++ kernelArgs kernel) num_groups group_size+      failure_params =+        [[C.cparam|__global int *global_failure|],+         [C.cparam|int failure_is_an_option|],+         [C.cparam|__global int *global_failure_args|]]++      params = perm_params +++               take (numFailureParams safety) failure_params +++               catMaybes local_memory_params +++               use_params++      kernel_fun =+        [C.cfun|__kernel void $id:name ($params:params) {+                  $items:const_defs+                  $items:block_dim_init+                  $items:local_memory_init+                  $items:error_init+                  $items:kernel_body++                  $id:(errorLabel kstate): return;++                  $items:const_undefs+                }|]+  modify $ \s -> s+    { clKernels = M.insert name (safety, kernel_fun) $ clKernels s+    , clUsedTypes = typesInKernel kernel <> clUsedTypes s+    , clFailures = kernelFailures kstate+    }++  -- The argument corresponding to the global_failure parameters is+  -- added automatically later.+  let args = catMaybes local_memory_args +++             kernelArgs kernel++  return $ LaunchKernel safety name args num_groups group_size   where name = nameToString $ kernelName kernel         num_groups = kernelNumGroups kernel         group_size = kernelGroupSize kernel@@ -201,10 +245,15 @@ useAsParam ConstUse{} =   Nothing -constDef :: KernelUse -> Maybe C.BlockItem-constDef (ConstUse v e) = Just [C.citem|const $ty:t $id:v = $exp:e';|]-  where t = GenericC.primTypeToCType $ primExpType e-        e' = compilePrimExp e+-- Constants are #defined as macros.  Since a constant name in one+-- kernel might potentially (although unlikely) also be used for+-- something else in another kernel, we #undef them after the kernel.+constDef :: KernelUse -> Maybe (C.BlockItem, C.BlockItem)+constDef (ConstUse v e) = Just ([C.citem|$escstm:def|],+                                [C.citem|$escstm:undef|])+  where e' = compilePrimExp e+        def = "#define " ++ pretty (C.toIdent v mempty) ++ " (" ++ pretty e' ++ ")"+        undef = "#undef " ++ pretty (C.toIdent v mempty) constDef _ = Nothing  openClCode :: [C.Func] -> String@@ -214,8 +263,8 @@           [[C.cedecl|$func:kernel_func|] |            kernel_func <- kernels ] -genOpenClPrelude :: OpenClRequirements -> [C.Definition]-genOpenClPrelude (OpenClRequirements ts) =+genOpenClPrelude :: S.Set PrimType -> [C.Definition]+genOpenClPrelude ts =   -- Clang-based OpenCL implementations need this for 'static' to work.   [ [C.cedecl|$esc:("#ifdef cl_clang_storage_class_specifiers")|]   , [C.cedecl|$esc:("#pragma OPENCL EXTENSION cl_clang_storage_class_specifiers : enable")|]@@ -286,8 +335,8 @@                   return atomicCAS(($ty:t *)p, cmp, val);                 }|] | t <- types] -genCUDAPrelude :: OpenClRequirements -> [C.Definition]-genCUDAPrelude (OpenClRequirements _) =+genCUDAPrelude :: [C.Definition]+genCUDAPrelude =   cudafy ++ cudaAtomicOps ++ ops   where ops = cIntOps ++ cFloat32Ops ++ cFloat32Funs ++ cFloat64Ops                 ++ cFloat64Funs ++ cFloatConvOps@@ -403,21 +452,42 @@         useToArg (ScalarUse v bt) = Just $ ValueKArg (LeafExp (ScalarVar v) bt) bt         useToArg ConstUse{}       = Nothing ---- Generating C+nextErrorLabel :: GenericC.CompilerM KernelOp KernelState String+nextErrorLabel =+  errorLabel <$> GenericC.getUserState -inKernelOperations :: GenericC.Operations KernelOp KernelRequirements-inKernelOperations = GenericC.Operations-                     { GenericC.opsCompiler = kernelOps-                     , GenericC.opsMemoryType = kernelMemoryType-                     , GenericC.opsWriteScalar = kernelWriteScalar-                     , GenericC.opsReadScalar = kernelReadScalar-                     , GenericC.opsAllocate = cannotAllocate-                     , GenericC.opsDeallocate = cannotDeallocate-                     , GenericC.opsCopy = copyInKernel-                     , GenericC.opsStaticArray = noStaticArrays-                     , GenericC.opsFatMemory = False-                     }-  where kernelOps :: GenericC.OpCompiler KernelOp KernelRequirements+incErrorLabel :: GenericC.CompilerM KernelOp KernelState ()+incErrorLabel =+  GenericC.modifyUserState $ \s -> s { kernelNextSync = kernelNextSync s + 1 }++pendingError :: Bool -> GenericC.CompilerM KernelOp KernelState ()+pendingError b =+  GenericC.modifyUserState $ \s -> s { kernelSyncPending = b }++hasCommunication :: ImpKernels.KernelCode -> Bool+hasCommunication = any communicates+  where communicates ErrorSync = True+        communicates LocalBarrier = True+        communicates GlobalBarrier = True+        communicates _ = False++inKernelOperations :: ImpKernels.KernelCode -> GenericC.Operations KernelOp KernelState+inKernelOperations body =+  GenericC.Operations+  { GenericC.opsCompiler = kernelOps+  , GenericC.opsMemoryType = kernelMemoryType+  , GenericC.opsWriteScalar = kernelWriteScalar+  , GenericC.opsReadScalar = kernelReadScalar+  , GenericC.opsAllocate = cannotAllocate+  , GenericC.opsDeallocate = cannotDeallocate+  , GenericC.opsCopy = copyInKernel+  , GenericC.opsStaticArray = noStaticArrays+  , GenericC.opsFatMemory = False+  , GenericC.opsError = errorInKernel+  }+  where has_communication = hasCommunication body++        kernelOps :: GenericC.OpCompiler KernelOp KernelState         kernelOps (GetGroupId v i) =           GenericC.stm [C.cstm|$id:v = get_group_id($int:i);|]         kernelOps (GetLocalId v i) =@@ -430,10 +500,12 @@           GenericC.stm [C.cstm|$id:v = get_global_size($int:i);|]         kernelOps (GetLockstepWidth v) =           GenericC.stm [C.cstm|$id:v = LOCKSTEP_WIDTH;|]-        kernelOps LocalBarrier =+        kernelOps LocalBarrier = do           GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|]-        kernelOps GlobalBarrier =+          GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }+        kernelOps GlobalBarrier = do           GenericC.stm [C.cstm|barrier(CLK_GLOBAL_MEM_FENCE);|]+          GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }         kernelOps MemFenceLocal =           GenericC.stm [C.cstm|mem_fence_local();|]         kernelOps MemFenceGlobal =@@ -445,14 +517,25 @@           GenericC.stm [C.cstm|$id:name = $id:name';|]         kernelOps (LocalAlloc name size) = do           name' <- newVName $ pretty name ++ "_backing"-          GenericC.modifyUserState (<>KernelRequirements [(name', size)])+          GenericC.modifyUserState $ \s ->+            s { kernelLocalMemory = (name', size) : kernelLocalMemory s }           GenericC.stm [C.cstm|$id:name = (__local char*) $id:name';|]+        kernelOps ErrorSync = do+          label <- nextErrorLabel+          pending <- kernelSyncPending <$> GenericC.getUserState+          when pending $ do+            pendingError False+            GenericC.stm [C.cstm|$id:label: barrier(CLK_LOCAL_MEM_FENCE);|]+            GenericC.stm [C.cstm|if (local_failure) { return; }|]+          GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|]+          GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }+          incErrorLabel         kernelOps (Atomic space aop) = atomicOps space aop          atomicCast s t = do           let volatile = [C.ctyquals|volatile|]-          quals <- case s of DefaultSpace -> pointerQuals "global"-                             Space sid    -> pointerQuals sid+          quals <- case s of Space sid    -> pointerQuals sid+                             _            -> pointerQuals "global"           return [C.cty|$tyquals:(volatile++quals) $ty:t|]          doAtomic s old arr ind val op ty = do@@ -498,45 +581,53 @@           cast <- atomicCast s [C.cty|int|]           GenericC.stm [C.cstm|$id:old = atomic_xchg(&(($ty:cast *)$id:arr)[$exp:ind'], $exp:val');|] -        cannotAllocate :: GenericC.Allocate KernelOp KernelRequirements+        cannotAllocate :: GenericC.Allocate KernelOp KernelState         cannotAllocate _ =           error "Cannot allocate memory in kernel" -        cannotDeallocate :: GenericC.Deallocate KernelOp KernelRequirements+        cannotDeallocate :: GenericC.Deallocate KernelOp KernelState         cannotDeallocate _ _ =           error "Cannot deallocate memory in kernel" -        copyInKernel :: GenericC.Copy KernelOp KernelRequirements+        copyInKernel :: GenericC.Copy KernelOp KernelState         copyInKernel _ _ _ _ _ _ _ =           error "Cannot bulk copy in kernel." -        noStaticArrays :: GenericC.StaticArray KernelOp KernelRequirements+        noStaticArrays :: GenericC.StaticArray KernelOp KernelState         noStaticArrays _ _ _ _ =           error "Cannot create static array in kernel." -        kernelMemoryType space-          | Just t <- M.lookup space allScalarMemory =-              return $ GenericC.primTypeToCType t-         kernelMemoryType space = do           quals <- pointerQuals space           return [C.cty|$tyquals:quals $ty:defaultMemBlockType|] -        kernelWriteScalar dest _ _ space _ v-          | space `M.member` allScalarMemory =-              GenericC.stm [C.cstm|$exp:dest = $exp:v;|]--        kernelWriteScalar dest i elemtype space vol v =+        kernelWriteScalar =           GenericC.writeScalarPointerWithQuals pointerQuals-          dest i elemtype space vol v -        kernelReadScalar dest _ _ space _-          | space `M.member` allScalarMemory =-              return dest--        kernelReadScalar dest i elemtype space vol =+        kernelReadScalar =           GenericC.readScalarPointerWithQuals pointerQuals-          dest i elemtype space vol++        errorInKernel msg@(ErrorMsg parts) backtrace = do+          n <- length . kernelFailures <$> GenericC.getUserState+          GenericC.modifyUserState $ \s ->+            s { kernelFailures = kernelFailures s ++ [FailureMsg msg backtrace] }+          let setArgs _ [] = return []+              setArgs i (ErrorString{} : parts') = setArgs i parts'+              setArgs i (ErrorInt32 x : parts') = do+                x' <- GenericC.compileExp x+                stms <- setArgs (i+1) parts'+                return $ [C.cstm|global_failure_args[$int:i] = $exp:x';|] : stms+          argstms <- setArgs (0::Int) parts+          label <- nextErrorLabel+          pendingError True+          let what_next+                | has_communication = [C.citems|local_failure = true;+                                                goto $id:label;|]+                | otherwise         = [C.citems|return;|]+          GenericC.stm [C.cstm|{ if (atomic_cmpxchg(global_failure, -1, $int:n) == -1)+                                 { $stms:argstms; }+                                 $items:what_next+                               }|]  --- Checking requirements
src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs view
@@ -221,6 +221,7 @@   , kernelNumGroups = num_groups   , kernelGroupSize = group_size   , kernelName = nameFromString name+  , kernelFailureTolerant = True   }   where pad2DBytes k = k * (k + 1) * primByteSize t         block_size =
src/Futhark/Compiler.hs view
@@ -32,6 +32,7 @@ import qualified Futhark.TypeCheck as I import Futhark.Compiler.Program import Futhark.Util.Log+import Futhark.Util.Pretty (prettyText)  data FutharkConfig = FutharkConfig                      { futharkVerbose :: (Verbosity, Maybe FilePath)@@ -51,8 +52,9 @@ dumpError config err =   case err of     ExternalError s -> do-      T.hPutStrLn stderr s-      T.hPutStrLn stderr "If you find this error message confusing, uninformative, or wrong, please open an issue at https://github.com/diku-dk/futhark/issues."+      T.hPutStrLn stderr $ prettyText s+      T.hPutStrLn stderr ""+      T.hPutStrLn stderr "If you find this error message confusing, uninformative, or wrong, please open an issue at\nhttps://github.com/diku-dk/futhark/issues."     InternalError s info CompilerBug -> do       T.hPutStrLn stderr "Internal compiler error."       T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues."
src/Futhark/Compiler/CLI.hs view
@@ -75,6 +75,9 @@   , Option [] ["executable"]     (NoArg $ Right $ \config -> config { compilerMode = ToExecutable })     "Generate an executable instead of a library (set by default)."+  , Option "w" []+    (NoArg $ Right $ \config -> config { compilerWarn = False })+    "Disable all warnings."   , Option [] ["Werror"]     (NoArg $ Right $ \config -> config { compilerWerror = True })     "Treat warnings as errors."@@ -103,6 +106,7 @@                  , compilerMode :: CompilerMode                  , compilerWerror :: Bool                  , compilerSafe :: Bool+                 , compilerWarn :: Bool                  , compilerConfig :: cfg                  } @@ -116,6 +120,7 @@                                      , compilerMode = ToExecutable                                      , compilerWerror = False                                      , compilerSafe = False+                                     , compilerWarn = True                                      , compilerConfig = x                                      } @@ -128,4 +133,5 @@   newFutharkConfig { futharkVerbose = compilerVerbose config                    , futharkWerror = compilerWerror config                    , futharkSafe = compilerSafe config+                   , futharkWarn = compilerWarn config                    }
src/Futhark/Compiler/Program.hs view
@@ -35,7 +35,8 @@ import qualified Language.Futhark as E import qualified Language.Futhark.TypeChecker as E import Language.Futhark.Semantic-import Language.Futhark.Futlib+import Language.Futhark.Prelude+import Futhark.Util.Pretty (ppr)  -- | A little monad for reading and type-checking a Futhark program. type CompilerM m = ReaderT [FilePath] (StateT ReaderState m)@@ -65,7 +66,7 @@               [ImportName] -> ImportName -> CompilerM m () readImport steps include   | include `elem` steps =-      throwError $ ExternalError $ T.pack $+      externalErrorS $       "Import cycle: " ++ intercalate " -> "       (map includeToString $ reverse $ include:steps)   | otherwise = do@@ -96,7 +97,7 @@    case E.checkProg imports src include $ prependRoots roots prog of     Left err ->-      externalError $ T.pack $ show err+      externalError $ ppr err     Right (m, ws, src') ->       modify $ \s ->         s { alreadyImported = (includeToString include,m) : imports@@ -121,12 +122,12 @@   -- then we look at the builtin library if we have to.  For the   -- builtins, we don't use the search path.   r <- liftIO $ readFileSafely $ includeToFilePath include-  case (r, lookup futlib_str futlib) of+  case (r, lookup prelude_str prelude) of     (Just (Right (filepath,s)), _) -> return (s, filepath)     (Just (Left e), _)  -> externalErrorS e-    (Nothing, Just t)   -> return (t, futlib_str)+    (Nothing, Just t)   -> return (t, prelude_str)     (Nothing, Nothing)  -> externalErrorS not_found-   where futlib_str = "/" Posix.</> includeToString include Posix.<.> "fut"+   where prelude_str = "/" Posix.</> includeToString include Posix.<.> "fut"           not_found =            "Error at " ++ E.locStr (srclocOf include) ++@@ -141,8 +142,8 @@                            VNameSource) readLibraryWithBasis builtin fps = do   (_, imps, src) <- runCompilerM builtin $-    mapM (readImport [] . mkInitialImport) prelude-  let basis = Basis imps src prelude+    readImport [] $ mkInitialImport "/prelude/prelude"+  let basis = Basis imps src ["/prelude/prelude"]   readLibrary' basis fps  -- | Read and type-check a Futhark library (multiple files, relative@@ -158,12 +159,12 @@           case r of             Just (Right (_, fs)) ->               handleFile [] (mkInitialImport fp_name) fs fp-            Just (Left e) -> externalError $ T.pack e+            Just (Left e) -> externalErrorS e             Nothing -> externalErrorS $ fp ++ ": file not found."             where (fp_name, _) = Posix.splitExtension fp  -- | Read and type-check Futhark imports (no @.fut@ extension; may--- refer to baked-in futlib).  This is an exotic operation that+-- refer to baked-in prelude).  This is an exotic operation that -- probably only makes sense in an interactive environment. readImports :: (MonadError CompilerError m, MonadIO m) =>                Basis -> [ImportName]
src/Futhark/Construct.hs view
@@ -42,6 +42,7 @@   , foldBinOp   , binOpLambda   , cmpOpLambda+  , sliceDim   , fullSlice   , fullSliceNum   , isFullSlice@@ -88,7 +89,7 @@   idents <- letBindNames vs e   case idents of     [ident] -> return $ identName ident-    _       -> fail $ "letExp: tuple-typed expression given:\n" ++ pretty e+    _       -> error $ "letExp: tuple-typed expression given:\n" ++ pretty e  letInPlace :: MonadBinder m =>               String -> VName -> Slice SubExp -> Exp (Lore m)@@ -188,7 +189,7 @@       return $ BasicOp $       BinOp (FSub float_t) (floatConst float_t 0) e'     _ ->-      fail $ "eNegate: operand " ++ pretty e ++ " has invalid type."+      error $ "eNegate: operand " ++ pretty e ++ " has invalid type."  eNot :: MonadBinder m =>         m (Exp (Lore m)) -> m (Exp (Lore m))@@ -206,7 +207,7 @@     Prim (FloatType float_t) ->       return $ BasicOp $ UnOp (FAbs float_t) e'     _ ->-      fail $ "eAbs: operand " ++ pretty e ++ " has invalid type."+      error $ "eAbs: operand " ++ pretty e ++ " has invalid type."  eSignum :: MonadBinder m =>         m (Exp (Lore m)) -> m (Exp (Lore m))@@ -218,7 +219,7 @@     Prim (IntType int_t) ->       return $ BasicOp $ UnOp (SSignum int_t) e'     _ ->-      fail $ "eSignum: operand " ++ pretty e ++ " has invalid type."+      error $ "eSignum: operand " ++ pretty e ++ " has invalid type."  eCopy :: MonadBinder m =>          m (Exp (Lore m)) -> m (Exp (Lore m))@@ -313,7 +314,7 @@ eBlank :: MonadBinder m => Type -> m (Exp (Lore m)) eBlank (Prim t) = return $ BasicOp $ SubExp $ Constant $ blankPrimValue t eBlank (Array pt shape _) = return $ BasicOp $ Scratch pt $ shapeDims shape-eBlank Mem{} = fail "eBlank: cannot create blank memory"+eBlank Mem{} = error "eBlank: cannot create blank memory"  -- | Sign-extend to the given integer type. asIntS :: MonadBinder m => IntType -> SubExp -> m SubExp@@ -331,7 +332,7 @@     Prim (IntType from_it)       | to_it == from_it -> return e       | otherwise -> letSubExp s $ BasicOp $ ConvOp (ext from_it to_it) e-    _ -> fail "asInt: wrong type"+    _ -> error "asInt: wrong type"   where s = case e of Var v -> baseString v                       _     -> "to_" ++ pretty to_it @@ -373,6 +374,7 @@            , lambdaBody       = body            } +-- | Slice a full dimension of the given size. sliceDim :: SubExp -> DimIndex SubExp sliceDim d = DimSlice (constant (0::Int32)) d (constant (1::Int32))
src/Futhark/Doc/Generator.hs view
@@ -308,7 +308,7 @@   return $ specRow lhs (mhs <> " : ") rhs  valBindHtml :: Html -> ValBind -> DocM (Html, Html, Html)-valBindHtml name (ValBind _ _ retdecl (Info rettype) tparams params _ _ _) = do+valBindHtml name (ValBind _ _ retdecl (Info (rettype, _)) tparams params _ _ _) = do   let tparams' = mconcat $ map ((" "<>) . typeParamHtml) tparams       noLink' = noLink $ map typeParamName tparams ++                 map identName (S.toList $ mconcat $ map patternIdents params)@@ -701,8 +701,10 @@  valBindWhat :: ValBind -> IndexWhat valBindWhat vb | null (valBindParams vb),-                 orderZero (unInfo (valBindRetType vb)) = IndexValue-               | otherwise                              = IndexFunction+                 orderZero (fst $ unInfo $ valBindRetType vb) =+                   IndexValue+               | otherwise =+                   IndexFunction  describeSpecs :: [Spec] -> DocM Html describeSpecs specs =
src/Futhark/Error.hs view
@@ -18,6 +18,7 @@  import Control.Monad.Error.Class import qualified Data.Text as T+import Futhark.Util.Pretty  -- | There are two classes of internal errors: actual bugs, and -- implementation limitations.  The latter are already known and need@@ -27,7 +28,7 @@                 deriving (Eq, Ord, Show)  data CompilerError =-    ExternalError T.Text+    ExternalError Doc     -- ^ An error that happened due to something the user did, such as     -- provide incorrect code or options.   | InternalError T.Text T.Text ErrorClass@@ -35,14 +36,14 @@     -- for debugging, which can be written to a file.  instance Show CompilerError where-  show (ExternalError s) = T.unpack s+  show (ExternalError s) = pretty s   show (InternalError s _ _) = T.unpack s -externalError :: MonadError CompilerError m => T.Text -> m a+externalError :: MonadError CompilerError m => Doc -> m a externalError = throwError . ExternalError  externalErrorS :: MonadError CompilerError m => String -> m a-externalErrorS = externalError . T.pack+externalErrorS = externalError . text  -- | An error that is not the users fault, but a bug (or limitation) -- in the compiler.  Compiler passes should only ever report this
src/Futhark/FreshNames.hs view
@@ -31,7 +31,8 @@  -- | Produce a fresh name, using the given name as a template. newName :: VNameSource -> VName -> (VName, VNameSource)-newName (VNameSource i) k = (VName (baseName k) i, VNameSource (i+1))+newName (VNameSource i) k = i' `seq` (VName (baseName k) i, VNameSource i')+  where i' = i+1  -- | A blank name source. blankNameSource :: VNameSource
src/Futhark/Internalise.hs view
@@ -12,6 +12,7 @@  import Control.Monad.State import Control.Monad.Reader+import Data.Bifunctor (first) import Data.Bitraversable import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -66,9 +67,9 @@     Nothing -> return $ nameFromString $ pretty ofname  internaliseValBind :: E.ValBind -> InternaliseM ()-internaliseValBind fb@(E.ValBind entry fname retdecl (Info rettype) tparams params body _ loc) = do+internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, retext)) tparams params body _ loc) = do   bindingParams tparams params $ \pcm shapeparams params' -> do-    (rettype_bad, rcm) <- internaliseReturnType rettype+    (rettype_bad, rcm) <- internaliseReturnType =<< existentialisedRetExt     let rettype' = zeroExts rettype_bad      let mkConstParam name = Param name $ I.Prim int32@@ -109,7 +110,9 @@     if null params'       then bindConstant fname (fname',                                pcm<>rcm,-                               applyRetType rettype' constparams)+                               applyRetType rettype' constparams,+                               bindExtSizes rettype retext,+                               namesFromList retext)       else bindFunction fname (fname',                                pcm<>rcm,                                map I.paramName free_params,@@ -127,6 +130,13 @@     -- them from somewhere else.     zeroExts ts = generaliseExtTypes ts ts +    existentialisedRetExt  = do+      sizes <- (namesFromList retext<>) <$> topLevelSizes+      let onDim (NamedDim v)+            | qualLeaf v `nameIn` sizes = AnyDim+          onDim d = d+      return $ first onDim rettype+ allDimsFreshInType :: MonadFreshNames m => E.PatternType -> m E.PatternType allDimsFreshInType = bitraverse onDim pure   where onDim (E.NamedDim v) =@@ -157,14 +167,14 @@   mapM allDimsFreshInPat pats <*> pure loc  generateEntryPoint :: E.StructType -> E.ValBind -> InternaliseM ()-generateEntryPoint ftype (E.ValBind _ ofname retdecl (Info rettype) _ params _ _ loc) = do+generateEntryPoint ftype (E.ValBind _ ofname retdecl (Info (rettype, _)) _ params _ _ loc) = do   -- We replace all shape annotations, so there should be no constant   -- parameters here.   params_fresh <- mapM allDimsFreshInPat params   let tparams = map (`E.TypeParamDim` noLoc) $ S.toList $                 mconcat $ map E.patternDimNames params_fresh   bindingParams tparams params_fresh $ \_ shapeparams params' -> do-    (entry_rettype, _) <- internaliseEntryReturnType $ anyDimShapeAnnotations rettype+    (entry_rettype, _) <- internaliseEntryReturnType $ anySizes rettype     let (e_paramts, e_rettype) = E.unfoldFunType ftype         entry' = entryPoint (zip3 params e_paramts params') (retdecl, e_rettype, entry_rettype)         args = map (I.Var . I.paramName) $ concat params'@@ -220,7 +230,7 @@         entryPointType (te, t, ts) =           [I.TypeOpaque desc $ length ts]           where desc = maybe (pretty t') typeExpOpaqueName te-                t' = removeShapeAnnotations t `E.setUniqueness` Nonunique+                t' = noSizes t `E.setUniqueness` Nonunique          -- | We remove dimension arguments such that we hopefully end         -- up with a simpler type name for the entry point.  The@@ -244,19 +254,18 @@ internaliseIdent (E.Ident name (Info tp) loc) =   case tp of     E.Scalar E.Prim{} -> return name-    _ -> fail $ "Futhark.Internalise.internaliseIdent: asked to internalise non-prim-typed ident '"+    _ -> error $ "Futhark.Internalise.internaliseIdent: asked to internalise non-prim-typed ident '"          ++ pretty name ++ " of type " ++ pretty tp ++          " at " ++ locStr loc ++ "."  internaliseBody :: E.Exp -> InternaliseM Body internaliseBody e = insertStmsM $ resultBody <$> internaliseExp "res" e -internaliseBodyStms :: E.Exp -> ([SubExp] -> InternaliseM (Body, a))-                    -> InternaliseM (Body, a)-internaliseBodyStms e m = do-  ((Body _ bnds res,x), otherbnds) <--    collectStms $ m =<< internaliseExp "res" e-  (,x) <$> mkBodyM (otherbnds <> bnds) res+bodyFromStms :: InternaliseM (Result, a)+             -> InternaliseM (Body, a)+bodyFromStms m = do+  ((res, a), stms) <- collectStms m+  (,a) <$> mkBodyM stms res  internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp] @@ -282,15 +291,24 @@         Just ses -> return ses         Nothing -> (:[]) . I.Var <$> internaliseIdent (E.Ident name (Info t) loc) -internaliseExp desc (E.Index e idxs _ loc) = do+internaliseExp desc (E.Index e idxs (Info ret, Info retext) loc) = do   vs <- internaliseExpToVars "indexed" e   dims <- case vs of []  -> return [] -- Will this happen?                      v:_ -> I.arrayDims <$> lookupType v   (idxs', cs) <- internaliseSlice loc dims idxs   let index v = do v_t <- lookupType v                    return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'-  certifying cs $ letSubExps desc =<< mapM index vs+  ses <- certifying cs $ letSubExps desc =<< mapM index vs+  bindExtSizes (E.toStruct ret) retext ses+  return ses +-- XXX: we map empty records and tuples to bools, because otherwise+-- arrays of unit will lose their sizes.+internaliseExp _ (E.TupLit [] _) =+  return [constant True]+internaliseExp _ (E.RecordLit [] _) =+  return [constant True]+ internaliseExp desc (E.TupLit es _) = concat <$> mapM (internaliseExp desc) es  internaliseExp desc (E.RecordLit orig_fields _) =@@ -321,25 +339,36 @@         letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr    | otherwise = do-  es' <- mapM (internaliseExp "arr_elem") es-  case es' of-    [] -> do-      rowtypes <- internaliseType $ toStructural rowtype-      let arraylit rt = I.BasicOp $ I.ArrayLit [] rt-      letSubExps desc $ map (arraylit . zeroDim . fromDecl) rowtypes-    e' : _ -> do-      rowtypes <- mapM subExpType e'+      (arr_t_ext, cm) <- internaliseReturnType $ E.toStruct arr_t+      mapM_ (uncurry (internaliseDimConstant loc)) cm+      es' <- mapM (internaliseExp "arr_elem") es++      let typeFromElements =+            -- XXX: the monomorphiser may create single-element array+            -- literals with an unknown row type.  In those cases we+            -- need to look at the types of the actual elements.+            -- Fixing this in the monomorphiser is a lot more tricky+            -- than just working around it here.+            case es' of+              [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t+              e':_ -> mapM subExpType e'++      rowtypes <-+        maybe typeFromElements pure $+        mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext+       let arraylit ks rt = do-            ks' <- mapM (ensureShape asserting "shape of element differs from shape of first element"+            ks' <- mapM (ensureShape asserting+                         "shape of element differs from shape of first element"                          loc rt "elem_reshaped") ks             return $ I.BasicOp $ I.ArrayLit ks' rt-      letSubExps desc =<< zipWithM arraylit (transpose es') rowtypes-  where rowtype = E.stripArray 1 arr_t -        zeroDim t = t `I.setArrayShape`-                    I.Shape (replicate (I.arrayRank t) (constant (0::Int32)))+      letSubExps desc =<<+        if null es'+        then mapM (arraylit []) rowtypes+        else zipWithM arraylit (transpose es') rowtypes -        isArrayLiteral :: E.Exp -> Maybe ([Int],[E.Exp])+  where isArrayLiteral :: E.Exp -> Maybe ([Int],[E.Exp])         isArrayLiteral (E.ArrayLit inner_es _ _) = do           (eshape,e):inner_es' <- mapM isArrayLiteral inner_es           guard $ all ((eshape==) . fst) inner_es'@@ -347,7 +376,7 @@         isArrayLiteral e =           Just ([], [e]) -internaliseExp desc (E.Range start maybe_second end _ loc) = do+internaliseExp desc (E.Range start maybe_second end (Info ret, Info retext) loc) = do   start' <- internaliseExp1 "range_start" start   end' <- internaliseExp1 "range_end" $ case end of     DownToExclusive e -> e@@ -380,7 +409,7 @@     case E.typeOf start of       E.Scalar (E.Prim (E.Signed it)) -> return (it, CmpSle it, CmpSlt it)       E.Scalar (E.Prim (E.Unsigned it)) -> return (it, CmpUle it, CmpUlt it)-      start_t -> fail $ "Start value in range has type " ++ pretty start_t+      start_t -> error $ "Start value in range has type " ++ pretty start_t    let one = intConst it 1       negone = intConst it (-1)@@ -458,14 +487,19 @@   step_i32 <- asIntS Int32 step   pos_step <- letSubExp "pos_step" $               I.BasicOp $ I.BinOp (Mul Int32) step_i32 step_sign_i32+   num_elems <- certifying cs $                letSubExp "num_elems" =<<                eDivRoundingUp Int32 (eSubExp distance) (eSubExp pos_step)    se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)+  bindExtSizes (E.toStruct ret) retext [se]   return [se] -internaliseExp desc (E.Ascript e (TypeDecl dt (Info et)) _ loc) = do+internaliseExp desc (E.Ascript e _ _) =+  internaliseExp desc e++internaliseExp desc (E.Coerce e (TypeDecl dt (Info et)) _ loc) = do   es <- internaliseExp desc e   (ts, cm) <- internaliseReturnType et   mapM_ (uncurry (internaliseDimConstant loc)) cm@@ -484,96 +518,102 @@                letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t) (I.intConst t 0) e'              I.Prim (I.FloatType t) ->                letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'-             _ -> fail "Futhark.Internalise.internaliseExp: non-numeric type in Negate"+             _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"  internaliseExp desc e@E.Apply{} = do-  (qfname, args) <- findFuncall e+  (qfname, args, ret, retext) <- findFuncall e+  -- Argument evaluation is outermost-in so that any existential sizes+  -- created by function applications can be brought into scope.   let fname = nameFromString $ pretty $ baseName $ qualLeaf qfname       loc = srclocOf e       arg_desc = nameToString fname ++ "_arg"    -- Some functions are magical (overloaded) and we handle that here.-  -- Note that polymorphic functions (which are not magical) are not-  -- handled here.-  case () of-    () | Just internalise <- isOverloadedFunction qfname args loc ->-           internalise desc-       | Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do-           let tag ses = [ (se, I.Observe) | se <- ses ]-           args' <- mapM (internaliseExp arg_desc) args-           let args'' = concatMap tag args'-           letTupExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, [])-       | otherwise -> do-           args' <- concat <$> mapM (internaliseExp arg_desc) args-           fst <$> funcall desc qfname args' loc+  ses <-+    case () of+      -- Overloaded functions never take array arguments (except+      -- equality, but those cannot be existential), so we can safely+      -- ignore the existential dimensions.+      () | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->+             internalise desc -internaliseExp desc (E.LetPat pat e body _ loc) =-  internalisePat desc pat e body loc (internaliseExp desc)+         | Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do+             let tag ses = [ (se, I.Observe) | se <- ses ]+             args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)+             let args'' = concatMap tag args'+             letTupExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, []) -internaliseExp desc (E.LetFun ofname (tparams, params, retdecl, Info rettype, body) letbody loc) = do-  internaliseValBind $ E.ValBind Nothing ofname retdecl (Info rettype) tparams params body Nothing loc-  internaliseExp desc letbody+         | otherwise -> do+             args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)+             fst <$> funcall desc qfname args' loc -internaliseExp desc (E.DoLoop mergepat mergeexp form loopbody loc) = do-  -- We pretend that we saw a let-binding first to ensure that the-  -- initial values for the merge parameters match their annotated-  -- sizes-  ses <- internaliseExp "loop_init" mergeexp-  t <- I.staticShapes <$> mapM I.subExpType ses-  stmPattern mergepat t $ \cm mergepat_names match -> do-    mapM_ (uncurry (internaliseDimConstant loc)) cm-    ses' <- match (srclocOf mergepat) ses-    forM_ (zip mergepat_names ses') $ \(v,se) ->-      letBindNames_ [v] $ I.BasicOp $ I.SubExp se-    let mergeinit = map I.Var mergepat_names+  bindExtSizes ret retext ses+  return ses -    (loopbody', (form', shapepat, mergepat', mergeinit', pre_stms)) <--      handleForm mergeinit form+internaliseExp desc (E.LetPat pat e body (Info ret, Info retext) loc) = do+  ses <- internalisePat desc pat e body loc (internaliseExp desc)+  bindExtSizes (E.toStruct ret) retext ses+  return ses -    addStms pre_stms+internaliseExp desc (E.LetFun ofname (tparams, params, retdecl, Info rettype, body) letbody _ loc) = do+  internaliseValBind $ E.ValBind Nothing ofname retdecl (Info (rettype, [])) tparams params body Nothing loc+  internaliseExp desc letbody -    mergeinit_ts' <- mapM subExpType mergeinit'+internaliseExp desc (E.DoLoop sparams mergepat mergeexp form loopbody (Info (ret, retext)) loc) = do+  ses <- internaliseExp "loop_init" mergeexp+  ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <-+    collectStms $ handleForm ses form -    ctxinit <- argShapes-               (map I.paramName shapepat)-               (map I.paramType mergepat')-               mergeinit_ts'-    let ctxmerge = zip shapepat ctxinit-        valmerge = zip mergepat' mergeinit'-        merge = ctxmerge ++ valmerge-        dropCond = case form of E.While{} -> drop 1-                                _         -> id+  addStms initstms+  mergeinit_ts' <- mapM subExpType mergeinit' -    -- Ensure that the result of the loop matches the shapes of the-    -- merge parameters, if any have been annotated by programmer.-    let merge_names = map (I.paramName . fst) merge-        merge_ts = existentialiseExtTypes merge_names $-                   staticShapes $ map (I.paramType . fst) merge-    loopbody'' <- localScope (scopeOfFParams $ map fst merge) $-                  inScopeOf form' $-                  ensureResultExtShapeNoCtx asserting-                  "shape of loop result does not match shapes in loop parameters"-                  loc merge_ts loopbody'+  let ctxinit = argShapes+                (map I.paramName shapepat)+                (map I.paramType mergepat')+                mergeinit_ts'+      ctxmerge = zip shapepat ctxinit+      valmerge = zip mergepat' mergeinit'+      dropCond = case form of E.While{} -> drop 1+                              _         -> id -    loop_res <- letTupExp desc $ I.DoLoop ctxmerge valmerge form' loopbody''-    return $ map I.Var $ dropCond loop_res+  -- Ensure that the result of the loop matches the shapes of the+  -- merge parameters.  XXX: Ideally they should already match (by+  -- the source language type rules), but some of our+  -- transformations (esp. defunctionalisation) strips out some size+  -- information.  For a type-correct source program, these reshapes+  -- should simplify away.+  let merge = ctxmerge ++ valmerge+      merge_names = map (I.paramName . fst) merge+      merge_ts = existentialiseExtTypes merge_names $+                 staticShapes $ map (I.paramType . fst) merge+  loopbody'' <- localScope (scopeOfFParams $ map fst merge) $+                inScopeOf form' $+                ensureResultExtShapeNoCtx asserting+                "shape of loop result does not match shapes in loop parameter"+                loc merge_ts loopbody' +  loop_res <- map I.Var . dropCond <$>+              letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody'')+  bindExtSizes (E.toStruct ret) retext loop_res+  return loop_res+   where-    forLoop nested_mergepat shapepat mergeinit form' =-      inScopeOf form' $ internaliseBodyStms loopbody $ \ses -> do-      sets <- mapM subExpType ses-      let mergepat' = concat nested_mergepat-      shapeargs <- argShapes-                   (map I.paramName shapepat)-                   (map I.paramType mergepat')-                   sets-      return (resultBody $ shapeargs ++ ses,-              (form',-               shapepat,-               mergepat',-               mergeinit,-               mempty))+    sparams' = map (`TypeParamDim` noLoc) sparams +    forLoop nested_mergepat shapepat mergeinit form' = do+      let mergepat' = concat nested_mergepat+      bodyFromStms $ inScopeOf form' $ do+        ses <- internaliseExp "loopres" loopbody+        sets <- mapM subExpType ses+        let shapeargs = argShapes+                        (map I.paramName shapepat)+                        (map I.paramType mergepat')+                        sets+        return (shapeargs ++ ses,+                (form',+                 shapepat,+                 mergepat',+                 mergeinit))      handleForm mergeinit (E.ForIn x arr) = do       arr' <- internaliseExpToVars "for_in_arr" arr@@ -582,7 +622,8 @@        i <- newVName "i" -      bindingParams [] [mergepat] $ \mergecm shapepat nested_mergepat ->+      bindingParams sparams' [mergepat] $+        \mergecm shapepat nested_mergepat ->         bindingLambdaParams [x] (map rowType arr_ts) $ \x_cm x_params -> do           mapM_ (uncurry (internaliseDimConstant loc)) x_cm           mapM_ (uncurry (internaliseDimConstant loc)) mergecm@@ -595,27 +636,28 @@       num_iterations_t <- I.subExpType num_iterations'       it <- case num_iterations_t of               I.Prim (IntType it) -> return it-              _                   -> fail "internaliseExp DoLoop: invalid type"+              _                   -> error "internaliseExp DoLoop: invalid type" -      bindingParams [] [mergepat] $ \mergecm shapepat nested_mergepat -> do-        mapM_ (uncurry (internaliseDimConstant loc)) mergecm-        forLoop nested_mergepat shapepat mergeinit $ I.ForLoop i' it num_iterations' []+      bindingParams sparams' [mergepat] $+        \mergecm shapepat nested_mergepat -> do+          mapM_ (uncurry (internaliseDimConstant loc)) mergecm+          forLoop nested_mergepat shapepat mergeinit $ I.ForLoop i' it num_iterations' []      handleForm mergeinit (E.While cond) =-      bindingParams [] [mergepat] $ \mergecm shapepat nested_mergepat -> do+      bindingParams sparams' [mergepat] $ \mergecm shapepat nested_mergepat -> do         mergeinit_ts <- mapM subExpType mergeinit         mapM_ (uncurry (internaliseDimConstant loc)) mergecm         let mergepat' = concat nested_mergepat         -- We need to insert 'cond' twice - once for the initial-        -- condition (do we enter the loop at all?), and once with-        -- the result values of the loop (do we continue into the-        -- next iteration?).  This is safe, as the type rules for-        -- the external language guarantees that 'cond' does not-        -- consume anything.-        shapeinit <- argShapes-                     (map I.paramName shapepat)-                     (map I.paramType mergepat')-                     mergeinit_ts+        -- condition (do we enter the loop at all?), and once with the+        -- result values of the loop (do we continue into the next+        -- iteration?).  This is safe, as the type rules for the+        -- external language guarantees that 'cond' does not consume+        -- anything.+        let shapeinit = argShapes+                        (map I.paramName shapepat)+                        (map I.paramType mergepat')+                        mergeinit_ts          (loop_initial_cond, init_loop_cond_bnds) <- collectStms $ do           forM_ (zip shapepat shapeinit) $ \(p, se) ->@@ -628,13 +670,16 @@                        _ -> SubExp se           internaliseExp1 "loop_cond" cond -        internaliseBodyStms loopbody $ \ses -> do+        addStms init_loop_cond_bnds++        bodyFromStms $ do+          ses <- internaliseExp "loopres" loopbody           sets <- mapM subExpType ses           loop_while <- newParam "loop_while" $ I.Prim I.Bool-          shapeargs <- argShapes-                       (map I.paramName shapepat)-                       (map I.paramType mergepat')-                       sets+          let shapeargs = argShapes+                          (map I.paramName shapepat)+                          (map I.paramType mergepat')+                          sets            -- Careful not to clobber anything.           loop_end_cond_body <- renameBody <=< insertStmsM $ do@@ -650,18 +695,17 @@             resultBody <$> internaliseExp "loop_cond" cond           loop_end_cond <- bodyBind loop_end_cond_body -          return (resultBody $ shapeargs++loop_end_cond++ses,+          return (shapeargs++loop_end_cond++ses,                   (I.WhileLoop $ I.paramName loop_while,                    shapepat,                    loop_while : mergepat',-                   loop_initial_cond : mergeinit,-                   init_loop_cond_bnds))+                   loop_initial_cond : mergeinit))  internaliseExp desc (E.LetWith name src idxs ve body t loc) = do   let pat = E.Id (E.identName name) (E.identType name) loc       src_t = E.fromStruct <$> E.identType src       e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc-  internaliseExp desc $ E.LetPat pat e body t loc+  internaliseExp desc $ E.LetPat pat e body (t, Info []) loc  internaliseExp desc (E.Update src slice ve loc) = do   ves <- internaliseExp "lw_val" ve@@ -695,8 +739,9 @@         replace _ _ ve' _ = return ve'  internaliseExp desc (E.Unsafe e _) =-  local (\env -> env { envDoBoundsChecks = False }) $-  internaliseExp desc e+  local mkUnsafe $ internaliseExp desc e+  where mkUnsafe env | envSafe env = env+                     | otherwise = env { envDoBoundsChecks = False }  internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do   e1' <- internaliseExp1 "assert_cond" e1@@ -721,7 +766,7 @@     Just (i, js) ->       (intConst Int8 (toInteger i):) <$> clauses 0 ts' (zip js es')     Nothing ->-      fail "internaliseExp Constr: missing constructor"+      error "internaliseExp Constr: missing constructor"    where clauses j (t:ts) js_to_es           | Just e <- j `lookup` js_to_es =@@ -733,11 +778,12 @@           return []  internaliseExp _ (E.Constr _ _ (Info t) loc) =-  fail $ "internaliseExp: constructor with type " ++ pretty t ++ " at " ++ locStr loc+  error $ "internaliseExp: constructor with type " ++ pretty t ++ " at " ++ locStr loc -internaliseExp desc (E.Match e cs _ _) = do+internaliseExp desc (E.Match e cs (Info ret, Info retext) _) = do   ses <- internaliseExp (desc ++ "_scrutinee") e-  case NE.uncons cs of+  res <-+    case NE.uncons cs of     (CasePat pCase eCase locCase, Nothing) -> do       (_, pertinent) <- generateCond pCase ses       internalisePat' pCase pertinent eCase locCase (internaliseExp desc)@@ -749,6 +795,8 @@         foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $           reverse $ NE.init cs'       letTupExp' desc =<< generateCaseIf ses c bFalse+  bindExtSizes (E.toStruct ret) retext res+  return res  -- The "interesting" cases are over, now it's mostly boilerplate. @@ -763,30 +811,35 @@       return [I.Constant $ I.IntValue $ intValue it v]     E.Scalar (E.Prim (E.FloatType ft)) ->       return [I.Constant $ I.FloatValue $ floatValue ft v]-    _ -> fail $ "internaliseExp: nonsensical type for integer literal: " ++ pretty t+    _ -> error $ "internaliseExp: nonsensical type for integer literal: " ++ pretty t  internaliseExp _ (E.FloatLit v (Info t) _) =   case t of     E.Scalar (E.Prim (E.FloatType ft)) ->       return [I.Constant $ I.FloatValue $ floatValue ft v]-    _ -> fail $ "internaliseExp: nonsensical type for float literal: " ++ pretty t+    _ -> error $ "internaliseExp: nonsensical type for float literal: " ++ pretty t -internaliseExp desc (E.If ce te fe _ _) =-  letTupExp' desc =<< eIf (BasicOp . SubExp <$> internaliseExp1 "cond" ce)-                          (internaliseBody te) (internaliseBody fe)+internaliseExp desc (E.If ce te fe (Info ret, Info retext) _) = do+  ses <- letTupExp' desc =<<+         eIf (BasicOp . SubExp <$> internaliseExp1 "cond" ce)+         (internaliseBody te) (internaliseBody fe)+  bindExtSizes (E.toStruct ret) retext ses+  return ses  -- Builtin operators are handled specially because they are -- overloaded.-internaliseExp desc (E.BinOp (op, _) _ (xe,_) (ye,_) _ loc)+internaliseExp desc (E.BinOp (op, _) _ (xe,_) (ye,_) _ _ loc)   | Just internalise <- isOverloadedFunction op [xe, ye] loc =       internalise desc  -- User-defined operators are just the same as a function call.-internaliseExp desc (E.BinOp (op, oploc) (Info t) (xarg, Info xt) (yarg, Info yt) _ loc) =+internaliseExp desc (E.BinOp (op, oploc) (Info t)+                     (xarg, Info (xt,xext)) (yarg, Info (yt,yext))+                     _ (Info retext) loc) =   internaliseExp desc $-  E.Apply (E.Apply (E.Var op (Info t) oploc) xarg (Info $ E.diet xt)-           (Info $ foldFunType [E.fromStruct yt] t) loc)-          yarg (Info $ E.diet yt) (Info t) loc+  E.Apply (E.Apply (E.Var op (Info t) oploc) xarg (Info (E.diet xt, xext))+           (Info $ foldFunType [E.fromStruct yt] t, Info []) loc)+          yarg (Info (E.diet yt, yext)) (Info t, Info retext) loc  internaliseExp desc (E.Project k e (Info rt) _) = do   n <- internalisedTypeSize $ rt `setAliases` ()@@ -798,23 +851,31 @@   take n . drop i' <$> internaliseExp desc e  internaliseExp _ e@E.Lambda{} =-  fail $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e)  internaliseExp _ e@E.OpSection{} =-  fail $ "internaliseExp: Unexpected operator section at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected operator section at " ++ locStr (srclocOf e)  internaliseExp _ e@E.OpSectionLeft{} =-  fail $ "internaliseExp: Unexpected left operator section at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected left operator section at " ++ locStr (srclocOf e)  internaliseExp _ e@E.OpSectionRight{} =-  fail $ "internaliseExp: Unexpected right operator section at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected right operator section at " ++ locStr (srclocOf e)  internaliseExp _ e@E.ProjectSection{} =-  fail $ "internaliseExp: Unexpected projection section at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected projection section at " ++ locStr (srclocOf e)  internaliseExp _ e@E.IndexSection{} =-  fail $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e)+  error $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e) +internaliseArg :: String -> (E.Exp, Maybe VName) -> InternaliseM [SubExp]+internaliseArg desc (arg, argdim) = do+  arg' <- internaliseExp desc arg+  case (arg', argdim) of+    ([se], Just d) -> letBindNames_ [d] $ BasicOp $ SubExp se+    _ -> return ()+  return arg'+ generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp]) generateCond orig_p orig_ses = do   (cmps, pertinent, _) <- compares orig_p orig_ses@@ -824,7 +885,7 @@     -- Literals are always primitive values.     compares (E.PatternLit e _ _) (se:ses) = do       e' <- internaliseExp1 "constant" e-      I.Prim t' <- subExpType se+      t' <- I.elemType <$> subExpType se       cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se       return ([cmp], [se], ses) @@ -838,10 +899,10 @@           (cmps, pertinent, _) <- comparesMany pats $ map (payload_ses!!) payload_is           return (cmp : cmps, pertinent, ses')         Nothing ->-          fail "generateCond: missing constructor"+          error "generateCond: missing constructor"      compares (E.PatternConstr _ (Info t) _ _) _ =-      fail $ "generateCond: PatternConstr has nonsensical type: " ++ pretty t+      error $ "generateCond: PatternConstr has nonsensical type: " ++ pretty t      compares (E.Id _ t loc) ses =       compares (E.Wildcard t loc) ses@@ -1100,7 +1161,7 @@   outsz  <- arraysSize 0 <$> mapM lookupType arrs   let acc_arr_tps = [ I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- acctps ]   lam0'  <- internaliseFoldLambda internaliseLambda lam0 acctps acc_arr_tps-  let lam0_acc_params = fst $ splitAt (length accs) $ I.lambdaParams lam0'+  let lam0_acc_params = take (length accs) $ I.lambdaParams lam0'   acc_params <- forM lam0_acc_params $ \p -> do     name <- newVName $ baseString $ I.paramName p     return p { I.paramName = name }@@ -1135,7 +1196,7 @@ internaliseExp1 desc e = do   vs <- internaliseExp desc e   case vs of [se] -> return se-             _ -> fail "Internalise.internaliseExp1: was passed not just a single subexpression"+             _ -> error "Internalise.internaliseExp1: was passed not just a single subexpression"  -- | Promote to dimension type as appropriate for the original type. -- Also return original type.@@ -1145,7 +1206,7 @@   case E.typeOf e of     E.Scalar (E.Prim (Signed it))   -> (,it) <$> asIntS Int32 e'     E.Scalar (E.Prim (Unsigned it)) -> (,it) <$> asIntZ Int32 e'-    _                               -> fail "internaliseDimExp: bad type"+    _                               -> error "internaliseDimExp: bad type"  internaliseExpToVars :: String -> E.Exp -> InternaliseM [I.VName] internaliseExpToVars desc e =@@ -1161,119 +1222,151 @@   vs <- internaliseExpToVars s e   letSubExps s =<< mapM (fmap I.BasicOp . op) vs -internaliseBinOp :: String+certifyingNonzero :: SrcLoc -> IntType -> SubExp+                  -> InternaliseM a+                  -> InternaliseM a+certifyingNonzero loc t x m = do+  c <- assertingOne $ do+    zero <- letSubExp "zero" $ I.BasicOp $+            CmpOp (CmpEq (IntType t)) x (intConst t 0)+    nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero+    letExp "nonzero_cert" $ I.BasicOp $+      I.Assert nonzero "division by zero" (loc, mempty)+  certifying c m++certifyingNonnegative :: SrcLoc -> IntType -> SubExp+                      -> InternaliseM a+                      -> InternaliseM a+certifyingNonnegative loc t x m = do+  c <- assertingOne $ do+    nonnegative <- letSubExp "nonnegative" $ I.BasicOp $+                   CmpOp (CmpSle t) (intConst t 0) x+    letExp "nonzero_cert" $ I.BasicOp $+      I.Assert nonnegative "negative exponent" (loc, mempty)+  certifying c m++internaliseBinOp :: SrcLoc -> String                  -> E.BinOp                  -> I.SubExp -> I.SubExp                  -> E.PrimType                  -> E.PrimType                  -> InternaliseM [I.SubExp]-internaliseBinOp desc E.Plus x y (E.Signed t) _ =+internaliseBinOp _ desc E.Plus x y (E.Signed t) _ =   simpleBinOp desc (I.Add t) x y-internaliseBinOp desc E.Plus x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Plus x y (E.Unsigned t) _ =   simpleBinOp desc (I.Add t) x y-internaliseBinOp desc E.Plus x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Plus x y (E.FloatType t) _ =   simpleBinOp desc (I.FAdd t) x y-internaliseBinOp desc E.Minus x y (E.Signed t) _ =+internaliseBinOp _ desc E.Minus x y (E.Signed t) _ =   simpleBinOp desc (I.Sub t) x y-internaliseBinOp desc E.Minus x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Minus x y (E.Unsigned t) _ =   simpleBinOp desc (I.Sub t) x y-internaliseBinOp desc E.Minus x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Minus x y (E.FloatType t) _ =   simpleBinOp desc (I.FSub t) x y-internaliseBinOp desc E.Times x y (E.Signed t) _ =+internaliseBinOp _ desc E.Times x y (E.Signed t) _ =   simpleBinOp desc (I.Mul t) x y-internaliseBinOp desc E.Times x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Times x y (E.Unsigned t) _ =   simpleBinOp desc (I.Mul t) x y-internaliseBinOp desc E.Times x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Times x y (E.FloatType t) _ =   simpleBinOp desc (I.FMul t) x y-internaliseBinOp desc E.Divide x y (E.Signed t) _ =+internaliseBinOp loc desc E.Divide x y (E.Signed t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.SDiv t) x y-internaliseBinOp desc E.Divide x y (E.Unsigned t) _ =+internaliseBinOp loc desc E.Divide x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.UDiv t) x y-internaliseBinOp desc E.Divide x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Divide x y (E.FloatType t) _ =   simpleBinOp desc (I.FDiv t) x y-internaliseBinOp desc E.Pow x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Pow x y (E.FloatType t) _ =   simpleBinOp desc (I.FPow t) x y-internaliseBinOp desc E.Pow x y (E.Signed t) _ =+internaliseBinOp loc desc E.Pow x y (E.Signed t) _ =+  certifyingNonnegative loc t y $   simpleBinOp desc (I.Pow t) x y-internaliseBinOp desc E.Pow x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Pow x y (E.Unsigned t) _ =   simpleBinOp desc (I.Pow t) x y-internaliseBinOp desc E.Mod x y (E.Signed t) _ =+internaliseBinOp loc desc E.Mod x y (E.Signed t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.SMod t) x y-internaliseBinOp desc E.Mod x y (E.Unsigned t) _ =+internaliseBinOp loc desc E.Mod x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.UMod t) x y-internaliseBinOp desc E.Mod x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Mod x y (E.FloatType t) _ =   simpleBinOp desc (I.FMod t) x y-internaliseBinOp desc E.Quot x y (E.Signed t) _ =+internaliseBinOp loc desc E.Quot x y (E.Signed t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.SQuot t) x y-internaliseBinOp desc E.Quot x y (E.Unsigned t) _ =+internaliseBinOp loc desc E.Quot x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.UDiv t) x y-internaliseBinOp desc E.Rem x y (E.Signed t) _ =+internaliseBinOp loc desc E.Rem x y (E.Signed t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.SRem t) x y-internaliseBinOp desc E.Rem x y (E.Unsigned t) _ =+internaliseBinOp loc desc E.Rem x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $   simpleBinOp desc (I.UMod t) x y-internaliseBinOp desc E.ShiftR x y (E.Signed t) _ =+internaliseBinOp _ desc E.ShiftR x y (E.Signed t) _ =   simpleBinOp desc (I.AShr t) x y-internaliseBinOp desc E.ShiftR x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.ShiftR x y (E.Unsigned t) _ =   simpleBinOp desc (I.LShr t) x y-internaliseBinOp desc E.ShiftL x y (E.Signed t) _ =+internaliseBinOp _ desc E.ShiftL x y (E.Signed t) _ =   simpleBinOp desc (I.Shl t) x y-internaliseBinOp desc E.ShiftL x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.ShiftL x y (E.Unsigned t) _ =   simpleBinOp desc (I.Shl t) x y-internaliseBinOp desc E.Band x y (E.Signed t) _ =+internaliseBinOp _ desc E.Band x y (E.Signed t) _ =   simpleBinOp desc (I.And t) x y-internaliseBinOp desc E.Band x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Band x y (E.Unsigned t) _ =   simpleBinOp desc (I.And t) x y-internaliseBinOp desc E.Xor x y (E.Signed t) _ =+internaliseBinOp _ desc E.Xor x y (E.Signed t) _ =   simpleBinOp desc (I.Xor t) x y-internaliseBinOp desc E.Xor x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Xor x y (E.Unsigned t) _ =   simpleBinOp desc (I.Xor t) x y-internaliseBinOp desc E.Bor x y (E.Signed t) _ =+internaliseBinOp _ desc E.Bor x y (E.Signed t) _ =   simpleBinOp desc (I.Or t) x y-internaliseBinOp desc E.Bor x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Bor x y (E.Unsigned t) _ =   simpleBinOp desc (I.Or t) x y -internaliseBinOp desc E.Equal x y t _ =+internaliseBinOp _ desc E.Equal x y t _ =   simpleCmpOp desc (I.CmpEq $ internalisePrimType t) x y-internaliseBinOp desc E.NotEqual x y t _ = do+internaliseBinOp _ desc E.NotEqual x y t _ = do   eq <- letSubExp (desc++"true") $ I.BasicOp $ I.CmpOp (I.CmpEq $ internalisePrimType t) x y   fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp I.Not eq-internaliseBinOp desc E.Less x y (E.Signed t) _ =+internaliseBinOp _ desc E.Less x y (E.Signed t) _ =   simpleCmpOp desc (I.CmpSlt t) x y-internaliseBinOp desc E.Less x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Less x y (E.Unsigned t) _ =   simpleCmpOp desc (I.CmpUlt t) x y-internaliseBinOp desc E.Leq x y (E.Signed t) _ =+internaliseBinOp _ desc E.Leq x y (E.Signed t) _ =   simpleCmpOp desc (I.CmpSle t) x y-internaliseBinOp desc E.Leq x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Leq x y (E.Unsigned t) _ =   simpleCmpOp desc (I.CmpUle t) x y-internaliseBinOp desc E.Greater x y (E.Signed t) _ =+internaliseBinOp _ desc E.Greater x y (E.Signed t) _ =   simpleCmpOp desc (I.CmpSlt t) y x -- Note the swapped x and y-internaliseBinOp desc E.Greater x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Greater x y (E.Unsigned t) _ =   simpleCmpOp desc (I.CmpUlt t) y x -- Note the swapped x and y-internaliseBinOp desc E.Geq x y (E.Signed t) _ =+internaliseBinOp _ desc E.Geq x y (E.Signed t) _ =   simpleCmpOp desc (I.CmpSle t) y x -- Note the swapped x and y-internaliseBinOp desc E.Geq x y (E.Unsigned t) _ =+internaliseBinOp _ desc E.Geq x y (E.Unsigned t) _ =   simpleCmpOp desc (I.CmpUle t) y x -- Note the swapped x and y-internaliseBinOp desc E.Less x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Less x y (E.FloatType t) _ =   simpleCmpOp desc (I.FCmpLt t) x y-internaliseBinOp desc E.Leq x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Leq x y (E.FloatType t) _ =   simpleCmpOp desc (I.FCmpLe t) x y-internaliseBinOp desc E.Greater x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Greater x y (E.FloatType t) _ =   simpleCmpOp desc (I.FCmpLt t) y x -- Note the swapped x and y-internaliseBinOp desc E.Geq x y (E.FloatType t) _ =+internaliseBinOp _ desc E.Geq x y (E.FloatType t) _ =   simpleCmpOp desc (I.FCmpLe t) y x -- Note the swapped x and y  -- Relational operators for booleans.-internaliseBinOp desc E.Less x y E.Bool _ =+internaliseBinOp _ desc E.Less x y E.Bool _ =   simpleCmpOp desc I.CmpLlt x y-internaliseBinOp desc E.Leq x y E.Bool _ =+internaliseBinOp _ desc E.Leq x y E.Bool _ =   simpleCmpOp desc I.CmpLle x y-internaliseBinOp desc E.Greater x y E.Bool _ =+internaliseBinOp _ desc E.Greater x y E.Bool _ =   simpleCmpOp desc I.CmpLlt y x -- Note the swapped x and y-internaliseBinOp desc E.Geq x y E.Bool _ =+internaliseBinOp _ desc E.Geq x y E.Bool _ =   simpleCmpOp desc I.CmpLle y x -- Note the swapped x and y -internaliseBinOp _ op _ _ t1 t2 =-  fail $ "Invalid binary operator " ++ pretty op +++internaliseBinOp _ _ op _ _ t1 t2 =+  error $ "Invalid binary operator " ++ pretty op ++   " with operand types " ++ pretty t1 ++ ", " ++ pretty t2  simpleBinOp :: String@@ -1290,14 +1383,17 @@ simpleCmpOp desc op x y =   letTupExp' desc $ I.BasicOp $ I.CmpOp op x y -findFuncall :: E.Exp -> InternaliseM (E.QualName VName, [E.Exp])-findFuncall (E.Var fname _ _) =-  return (fname, [])-findFuncall (E.Apply f arg _ _ _) = do-  (fname, args) <- findFuncall f-  return (fname, args ++ [arg])+findFuncall :: E.Exp -> InternaliseM (E.QualName VName,+                                      [(E.Exp, Maybe VName)],+                                      E.StructType,+                                      [VName])+findFuncall (E.Var fname (Info t) _) =+  return (fname, [], E.toStruct t, [])+findFuncall (E.Apply f arg (Info (_, argext)) (Info ret, Info retext) _) = do+  (fname, args, _, _) <- findFuncall f+  return (fname, args ++ [(arg, argext)], E.toStruct ret, retext) findFuncall e =-  fail $ "Invalid function expression in application: " ++ pretty e+  error $ "Invalid function expression in application: " ++ pretty e  internaliseLambda :: InternaliseLambda @@ -1311,7 +1407,7 @@     mapM_ (uncurry (internaliseDimConstant loc)) $ pcm<>rcm     return (params', body', map I.fromDecl rettype') -internaliseLambda e _ = fail $ "internaliseLambda: unexpected expression:\n" ++ pretty e+internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e  internaliseDimConstant :: SrcLoc -> Name -> VName -> InternaliseM () internaliseDimConstant loc fname name =@@ -1363,10 +1459,10 @@     -- Short-circuiting operators are magical.     handle [x,y] "&&" = Just $ \desc ->       internaliseExp desc $-      E.If x y (E.Literal (E.BoolValue False) noLoc) (Info $ E.Scalar $ E.Prim E.Bool) noLoc+      E.If x y (E.Literal (E.BoolValue False) noLoc) (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc     handle [x,y] "||" = Just $ \desc ->         internaliseExp desc $-        E.If x (E.Literal (E.BoolValue True) noLoc) y (Info $ E.Scalar $ E.Prim E.Bool) noLoc+        E.If x (E.Literal (E.BoolValue True) noLoc) y (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc      -- Handle equality and inequality specially, to treat the case of     -- arrays.@@ -1425,8 +1521,8 @@         y' <- internaliseExp1 "y" y         case (E.typeOf x, E.typeOf y) of           (E.Scalar (E.Prim t1), E.Scalar (E.Prim t2)) ->-            internaliseBinOp desc bop x' y' t1 t2-          _ -> fail "Futhark.Internalise.internaliseExp: non-primitive type in BinOp."+            internaliseBinOp loc desc bop x' y' t1 t2+          _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in BinOp."      handle [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF a si v @@ -1568,7 +1664,7 @@           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'         E.Scalar (E.Prim (E.FloatType float_from)) ->           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToSI float_from int_to) e'-        _ -> fail "Futhark.Internalise.handle: non-numeric type in ToSigned"+        _ -> error "Futhark.Internalise.handle: non-numeric type in ToSigned"      toUnsigned int_to e desc = do       e' <- internaliseExp1 "trunc_arg" e@@ -1583,7 +1679,7 @@           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'         E.Scalar (E.Prim (E.FloatType float_from)) ->           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToUI float_from int_to) e'-        _ -> fail "Futhark.Internalise.internaliseExp: non-numeric type in ToUnsigned"+        _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in ToUnsigned"      complementF e desc = do       e' <- internaliseExp1 "complement_arg" e@@ -1593,7 +1689,7 @@                  I.Prim I.Bool ->                    letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e'                  _ ->-                   fail "Futhark.Internalise.internaliseExp: non-int/bool type in Complement"+                   error "Futhark.Internalise.internaliseExp: non-int/bool type in Complement"      scatterF a si v desc = do       si' <- letExp "write_si" . BasicOp . SubExp =<< internaliseExp1 "write_arg_i" si@@ -1653,17 +1749,19 @@   is_const <- lookupConst name   scope <- askScope   case is_const of-    Just (fname, constparams, mk_rettype)+    Just (fname, constparams, mk_rettype, bind_ext, _)       | name `M.notMember` scope -> do       (constargs, const_ds, const_ts) <- unzip3 <$> constFunctionArgs loc constparams       safety <- askSafety       case mk_rettype $ zip constargs $ map I.fromDecl const_ts of-        Nothing -> fail $ "internaliseIfConst: " +++        Nothing -> error $ "internaliseIfConst: " ++                    unwords (pretty name : zipWith (curry pretty) constargs const_ts) ++                    " failed"-        Just rettype ->-          fmap (Just . map I.Var) $ letTupExp (baseString name) $-          I.Apply fname (zip constargs const_ds) rettype (safety, loc, mempty)+        Just rettype -> do+          ses <- fmap (map I.Var) $ letTupExp (baseString name) $+                 I.Apply fname (zip constargs const_ds) rettype (safety, loc, mempty)+          bind_ext ses+          return $ Just ses     _ -> return Nothing  constFunctionArgs :: SrcLoc -> ConstParams -> InternaliseM [(SubExp, I.Diet, I.DeclType)]@@ -1682,8 +1780,8 @@   (constargs, const_ds, _) <- unzip3 <$> constFunctionArgs loc constparams   argts <- mapM subExpType args   closure_ts <- mapM lookupType closure-  shapeargs <- argShapes shapes value_paramts argts-  let diets = const_ds ++ replicate (length closure + length shapeargs) I.ObservePrim +++  let shapeargs = argShapes shapes value_paramts argts+      diets = const_ds ++ replicate (length closure + length shapeargs) I.ObservePrim ++               map I.diet value_paramts       constOrShape = const $ I.Prim int32       paramts = map constOrShape constargs ++ closure_ts ++@@ -1693,7 +1791,7 @@            paramts (constargs ++ map I.Var closure ++ shapeargs ++ args)   argts' <- mapM subExpType args'   case rettype_fun $ zip args' argts' of-    Nothing -> fail $ "Cannot apply " ++ pretty fname ++ " to arguments\n " +++    Nothing -> error $ "Cannot apply " ++ pretty fname ++ " to arguments\n " ++                pretty args' ++ "\nof types\n " ++                pretty argts' ++                "\nFunction has parameters\n " ++ pretty fun_params@@ -1702,10 +1800,29 @@       ses <- letTupExp' desc $ I.Apply fname' (zip args' diets) ts (safety, loc, mempty)       return (ses, map I.fromDecl ts) +-- Bind existential names defined by an expression, based on the+-- concrete values that expression evaluated to.  This most+-- importantly should be done after function calls, but also+-- everything else that can produce existentials in the source+-- language.+bindExtSizes :: E.StructType -> [VName] -> [SubExp] -> InternaliseM ()+bindExtSizes ret retext ses = do+  ts <- concat . fst <$>+        internaliseParamTypes mempty (M.fromList $ zip retext retext) [ret]+  ses_ts <- mapM subExpType ses++  let combine t1 t2 =+        mconcat $ zipWith combine' (arrayExtDims t1) (arrayDims t2)+      combine' (I.Free (I.Var v)) se+        | v `elem` retext = M.singleton v se+      combine' _ _ = mempty++  forM_ (M.toList $ mconcat $ zipWith combine ts ses_ts) $ \(v, se) ->+    letBindNames_ [v] $ BasicOp $ SubExp se+ askSafety :: InternaliseM Safety askSafety = do check <- asks envDoBoundsChecks-               safe <- asks envSafe-               return $ if check || safe then I.Safe else I.Unsafe+               return $ if check then I.Safe else I.Unsafe  -- Implement partitioning using maps, scans and writes. partitionWithSOACS :: Int -> I.Lambda -> [I.VName] -> InternaliseM ([I.SubExp], [I.SubExp])@@ -1715,7 +1832,7 @@   classes_and_increments <- letTupExp "increments" $ I.Op $ I.Screma w (mapSOAC lam) arrs   (classes, increments) <- case classes_and_increments of                              classes : increments -> return (classes, take k increments)-                             _                    -> fail "partitionWithSOACS"+                             _                    -> error "partitionWithSOACS"    add_lam_x_params <-     replicateM k $ I.Param <$> newVName "x" <*> pure (I.Prim int32)
src/Futhark/Internalise/AccurateSizes.hs view
@@ -27,7 +27,7 @@   runBodyBinder $ do     ses <- bodyBind body     sets <- mapM subExpType ses-    resultBody <$> argShapes shapenames ts sets+    resultBodyM $ argShapes shapenames ts sets  annotateArrayShape :: ArrayShape shape =>                       TypeBase shape u -> [Int] -> TypeBase Shape u@@ -35,25 +35,14 @@   t `setArrayShape` Shape (take (arrayRank t) $                            map (intConst Int32 . toInteger) $ newshape ++ repeat 0) --- Some trickery is needed here to predict sensible values for--- dimensions that are used exclusively as the inner dimension of an--- array.  The issue is that the dimension may be inside an empty--- array.  In this case, the dimension inside the empty array should--- not count, as it will be zero.  The solution we use is to take the--- maximum of such sizes; this will effectively disregard the zeroes.-argShapes :: MonadBinder m =>-             [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> m [SubExp]+argShapes :: [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> [SubExp] argShapes shapes valts valargts =-  mapM addShape shapes+  map addShape shapes   where mapping = shapeMapping valts valargts-        outer_dims = map (arraySize 0) valts         addShape name =           case M.lookup name mapping of-            Just s | x:xs <- S.toList s ->-                       if Var name `elem` outer_dims-                       then return x-                       else letSubExp (baseString name) =<< foldBinOp (SMax Int32) x xs-            _ -> return $ intConst Int32 0+            Just s | se:_ <- S.toList s -> se+            _ -> intConst Int32 0  ensureResultShape :: MonadBinder m =>                      (m Certificates -> m Certificates)@@ -119,7 +108,6 @@           | otherwise =               ensureShape asserting msg loc t (baseString v) $ Var v - ensureShapeVar :: MonadBinder m =>                   (m Certificates -> m Certificates)                -> ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> VName@@ -132,20 +120,11 @@       then return v       else do         certs <- asserting $ do-          old_zero <- letSubExp "old_empty" =<< anyZero olddims-          new_zero <- letSubExp "new_empty" =<< anyZero newdims-          both_empty <- letSubExp "both_empty" $ BasicOp $ BinOp LogAnd old_zero new_zero-           matches <- zipWithM checkDim newdims olddims           all_match <- letSubExp "match" =<< foldBinOp LogAnd (constant True) matches--          empty_or_match <- letSubExp "empty_or_match" $ BasicOp $ BinOp LogOr both_empty all_match           Certificates . pure <$> letExp "empty_or_match_cert"-            (BasicOp $ Assert empty_or_match msg (loc, []))+            (BasicOp $ Assert all_match msg (loc, []))         certifying certs $ letExp name $ shapeCoerce newdims v   | otherwise = return v   where checkDim desired has =           letSubExp "dim_match" $ BasicOp $ CmpOp (CmpEq int32) desired has-        anyZero =-          foldBinOp LogOr (constant False) <=<-          mapM (letSubExp "dim_zero" . BasicOp . CmpOp (CmpEq int32) (intConst Int32 0))
src/Futhark/Internalise/Bindings.hs view
@@ -17,7 +17,7 @@ import qualified Data.Set as S import Data.Loc -import Language.Futhark as E+import Language.Futhark as E hiding (matchDims) import qualified Futhark.Representation.SOACS as I import Futhark.MonadFreshNames import Futhark.Internalise.Monad@@ -129,6 +129,11 @@           new_name <- newVName $ baseString v           return [((E.Ident v (Info t) loc, new_name),                    t `E.setAliases` ())]+        -- XXX: treat empty tuples and records as bool.+        flattenPattern' (E.TuplePattern [] loc) =+          flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc)+        flattenPattern' (E.RecordPattern [] loc) =+          flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc)         flattenPattern' (E.TuplePattern pats _) =           concat <$> mapM flattenPattern' pats         flattenPattern' (E.RecordPattern fs loc) =
src/Futhark/Internalise/Defunctionalise.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-} -- | Defunctionalization of typed, monomorphic Futhark programs without modules. module Futhark.Internalise.Defunctionalise   ( transformProg ) where  import qualified Control.Arrow as Arrow+import           Control.Monad.State import           Control.Monad.RWS hiding (Sum) import           Data.Bifunctor import           Data.Foldable@@ -111,9 +113,39 @@     Nothing -- If the variable is unknown, it may refer to the 'intrinsics'             -- module, which we will have to treat specially.       | baseTag x <= maxIntrinsicTag -> return IntrinsicSV-      | otherwise -> error $ "Variable " ++ pretty x ++ " at "+      | otherwise -> -- Anything not in scope is going to be an+                     -- existential size.+          return $ Dynamic $ Scalar $ Prim $ Signed Int32+      | otherwise ->  error $ "Variable " ++ pretty x ++ " at "                           ++ locStr loc ++ " is out of scope." +-- Like patternDimNames, but ignores sizes that are only found in+-- funtion types.+arraySizes :: StructType -> S.Set VName+arraySizes (Scalar Arrow{}) = mempty+arraySizes (Scalar (Record fields)) = foldMap arraySizes fields+arraySizes (Scalar (Sum cs)) = foldMap (foldMap arraySizes) cs+arraySizes (Scalar TypeVar{}) = mempty+arraySizes (Scalar Prim{}) = mempty+arraySizes (Array _ _ t shape) =+  arraySizes (Scalar t) <> foldMap dimName (shapeDims shape)+  where dimName :: DimDecl VName -> S.Set VName+        dimName (NamedDim qn) = S.singleton $ qualLeaf qn+        dimName _             = mempty++patternArraySizes :: Pattern -> S.Set VName+patternArraySizes = arraySizes . patternStructType++dimMapping :: Monoid a =>+              TypeBase (DimDecl VName) a+           -> TypeBase (DimDecl VName) a+           -> M.Map VName VName+dimMapping t1 t2 = execState (matchDims f t1 t2) mempty+  where f (NamedDim d1) (NamedDim d2) = do+          modify $ M.insert (qualLeaf d1) (qualLeaf d2)+          return $ NamedDim d1+        f d _ = return d+ defuncFun :: [TypeParam] -> [Pattern] -> Exp -> (Aliasing, StructType) -> SrcLoc           -> DefM (Exp, StaticVal) defuncFun tparams pats e0 (closure, ret) loc = do@@ -129,7 +161,7 @@           -- Split shape parameters into those that are determined by           -- the first pattern, and those that are determined by later           -- patterns.-          let bound_by_pat = (`S.member` patternDimNames pat') . typeParamName+          let bound_by_pat = (`S.member` patternArraySizes pat') . typeParamName               (pat_dims, rest_dims) = partition bound_by_pat tparams           in (map typeParamName pat_dims, pat',               foldFunType (map (toStruct . patternType) pats') ret,@@ -139,20 +171,21 @@   -- the lambda.  Closed-over 'DynamicFun's are converted to their   -- closure representation.   let used = freeVars (Lambda pats e0 Nothing (Info (closure, ret)) loc)-             `without` mconcat (map (oneName . typeParamName) tparams)-  env <- restrictEnvTo used+             `without` mconcat (map oneName dims)+  used_env <- restrictEnvTo used -  let (fields, env') = unzip $ map closureFromDynamicFun $ M.toList env-      env'' = M.fromList env'-      dimIfNotInClosure v = do-        guard $ v `M.notMember` env''-        guard $ v `notElem` dims-        return v-      closure_dims =-        mapMaybe dimIfNotInClosure $ S.toList $ patternDimNames pat+  -- The closure parts that are sizes are proactively turned into size+  -- parameters.+  let sizes_of_arrays = foldMap (arraySizes . toStruct . typeFromSV) used_env <>+                        patternArraySizes pat+      notSize = not . (`S.member` sizes_of_arrays)+      (fields, env) = unzip $ map closureFromDynamicFun $+                      filter (notSize . fst) $ M.toList used_env+      env' = M.fromList env+      closure_dims = S.toList sizes_of_arrays    return (RecordLit fields loc,-          LambdaSV (dims++closure_dims) pat ret' e0' env'')+          LambdaSV (nub $ dims<>closure_dims) pat ret' e0' env')    where closureFromDynamicFun (vn, DynamicFun (clsr_env, sv) _) =           let name = nameFromString $ pretty vn@@ -217,7 +250,7 @@   es' <- mapM defuncExp' es   return (ArrayLit es' t loc, Dynamic t') -defuncExp (Range e1 me incl t@(Info t') loc) = do+defuncExp (Range e1 me incl t@(Info t', _) loc) = do   e1' <- defuncExp' e1   me' <- mapM defuncExp' me   incl' <- mapM defuncExp' incl@@ -233,29 +266,40 @@     -- Intrinsic functions used as variables are eta-expanded, so we     -- can get rid of them.     IntrinsicSV -> do-      (pats, body, tp) <- etaExpand e+      (pats, body, tp) <- etaExpand (typeOf e) e       defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) noLoc     _ -> let tp = typeFromSV sv          in return (Var qn (Info tp) loc, sv) -defuncExp (Ascript e0 tydecl t loc)+defuncExp (Ascript e0 tydecl loc)   | orderZero (typeOf e0) = do (e0', sv) <- defuncExp e0-                               return (Ascript e0' tydecl t loc, sv)+                               return (Ascript e0' tydecl loc, sv)   | otherwise = defuncExp e0 -defuncExp (LetPat pat e1 e2 _ loc) = do+defuncExp (Coerce e0 tydecl t loc)+  | orderZero (typeOf e0) = do (e0', sv) <- defuncExp e0+                               return (Coerce e0' tydecl t loc, sv)+  | otherwise = defuncExp e0++defuncExp (LetPat pat e1 e2 (Info t, retext) loc) = do   (e1', sv1) <- defuncExp e1   let env  = matchPatternSV pat sv1       pat' = updatePattern pat sv1   (e2', sv2) <- localEnv env $ defuncExp e2-  return (LetPat pat' e1' e2' (Info $ typeOf e2') loc, sv2)+  -- To maintain any sizes going out of scope, we need to compute the+  -- old size substitution induced by retext and also apply it to the+  -- newly computed body type.+  let mapping = dimMapping (typeOf e2) t+      subst v = fromMaybe v $ M.lookup v mapping+      t' = first (fmap subst) $ typeOf e2'+  return (LetPat pat' e1' e2' (Info t', retext) loc, sv2)  -- Local functions are handled by rewriting them to lambdas, so that -- the same machinery can be re-used.-defuncExp (LetFun vn (dims, pats, _, Info ret, e1) e2 loc) = do+defuncExp (LetFun vn (dims, pats, _, Info ret, e1) e2 _ loc) = do   (e1', sv1) <- defuncFun dims pats e1 (mempty, ret) loc   (e2', sv2) <- localEnv (M.singleton vn sv1) $ defuncExp e2-  return (LetPat (Id vn (Info (typeOf e1')) loc) e1' e2' (Info $ typeOf e2') loc,+  return (LetPat (Id vn (Info (typeOf e1')) loc) e1' e2' (Info $ typeOf e2', Info []) loc,           sv2)  defuncExp (If e1 e2 e3 tp loc) = do@@ -264,12 +308,12 @@   (e3', _ ) <- defuncExp e3   return (If e1' e2' e3' tp loc, sv) -defuncExp e@(Apply f@(Var f' _ _) arg d t loc)+defuncExp e@(Apply f@(Var f' _ _) arg d (t, ext) loc)   | baseTag (qualLeaf f') <= maxIntrinsicTag,     TupLit es tuploc <- arg = do       -- defuncSoacExp also works fine for non-SOACs.       es' <- mapM defuncSoacExp es-      return (Apply f (TupLit es' tuploc) d t loc,+      return (Apply f (TupLit es' tuploc) d (t, ext) loc,               Dynamic $ typeOf e)  defuncExp e@Apply{} = defuncApply 0 e@@ -289,7 +333,7 @@ defuncExp ProjectSection{} = error "defuncExp: unexpected projection section." defuncExp IndexSection{}   = error "defuncExp: unexpected projection section." -defuncExp (DoLoop pat e1 form e3 loc) = do+defuncExp (DoLoop sparams pat e1 form e3 ret loc) = do   (e1', sv1) <- defuncExp e1   let env1 = matchPatternSV pat sv1   (form', env2) <- case form of@@ -300,15 +344,18 @@     While e2      -> do e2' <- localEnv env1 $ defuncExp' e2                         return (While e2', mempty)   (e3', sv) <- localEnv (env1 <> env2) $ defuncExp e3-  return (DoLoop pat e1' form' e3' loc, sv)+  return (DoLoop sparams pat e1' form' e3' ret loc, sv)   where envFromIdent (Ident vn (Info tp) _) =           M.singleton vn $ Dynamic tp  -- We handle BinOps by turning them into ordinary function applications.-defuncExp (BinOp (qn, qnloc) (Info t) (e1, Info pt1) (e2, Info pt2) (Info ret) loc) =+defuncExp (BinOp (qn, qnloc) (Info t)+           (e1, Info (pt1, ext1)) (e2, Info (pt2, ext2))+           (Info ret) (Info retext) loc) =   defuncExp $ Apply (Apply (Var qn (Info t) qnloc)-                     e1 (Info (diet pt1)) (Info (Scalar $ Arrow mempty Unnamed (fromStruct pt2) ret)) loc)-                    e2 (Info (diet pt2)) (Info ret) loc+                     e1 (Info (diet pt1, ext1))+                     (Info (Scalar $ Arrow mempty Unnamed (fromStruct pt2) ret), Info []) loc)+                    e2 (Info (diet pt2, ext2)) (Info ret, Info retext) loc  defuncExp (Project vn e0 tp@(Info tp') loc) = do   (e0', sv0) <- defuncExp e0@@ -429,27 +476,28 @@  defuncSoacExp e   | Scalar Arrow{} <- typeOf e = do-      (pats, body, tp) <- etaExpand e+      (pats, body, tp) <- etaExpand (typeOf e) e       let env = foldMap envFromPattern pats       body' <- localEnv env $ defuncExp' body       return $ Lambda pats body' Nothing (Info (mempty, tp)) noLoc   | otherwise = defuncExp' e -etaExpand :: Exp -> DefM ([Pattern], Exp, StructType)-etaExpand e = do-  let (ps, ret) = getType $ typeOf e-  (pats, vars) <- fmap unzip . forM ps $ \t -> do-    x <- newNameFromString "x"+etaExpand :: PatternType -> Exp -> DefM ([Pattern], Exp, StructType)+etaExpand e_t e = do+  let (ps, ret) = getType e_t+  (pats, vars) <- fmap unzip . forM ps $ \(p, t) -> do+    x <- case p of Named x -> pure x+                   Unnamed -> newNameFromString "x"     return (Id x (Info t) noLoc,             Var (qualName x) (Info t) noLoc)   let e' = foldl' (\e1 (e2, t2, argtypes) ->-                     Apply e1 e2 (Info $ diet t2)-                     (Info (foldFunType argtypes ret)) noLoc)-           e $ zip3 vars ps (drop 1 $ tails ps)+                     Apply e1 e2 (Info (diet t2, Nothing))+                     (Info (foldFunType argtypes ret), Info []) noLoc)+           e $ zip3 vars (map snd ps) (drop 1 $ tails $ map snd ps)   return (pats, e', toStruct ret) -  where getType (Scalar (Arrow _ _ t1 t2)) =-          let (ps, r) = getType t2 in (t1 : ps, r)+  where getType (Scalar (Arrow _ p t1 t2)) =+          let (ps, r) = getType t2 in ((p,t1) : ps, r)         getType t = ([], t)  -- | Defunctionalize an indexing of a single array dimension.@@ -461,25 +509,25 @@  -- | Defunctionalize a let-bound function, while preserving parameters -- that have order 0 types (i.e., non-functional).-defuncLet :: [TypeParam] -> [Pattern] -> Exp -> Info StructType+defuncLet :: [TypeParam] -> [Pattern] -> Exp -> StructType           -> DefM ([TypeParam], [Pattern], Exp, StaticVal)-defuncLet dims ps@(pat:pats) body (Info rettype)+defuncLet dims ps@(pat:pats) body rettype   | patternOrderZero pat = do        let bound_by_pat = (`S.member` patternDimNames pat) . typeParamName           -- Take care to not include more size parameters than necessary.           (pat_dims, rest_dims) = partition bound_by_pat dims           env = envFromPattern pat <> envFromShapeParams pat_dims-      (rest_dims', pats', body', sv) <- localEnv env $ defuncLet rest_dims pats body (Info rettype)+      (rest_dims', pats', body', sv) <- localEnv env $ defuncLet rest_dims pats body rettype       closure <- defuncFun dims ps body (mempty, rettype) noLoc       return (pat_dims ++ rest_dims', pat : pats', body', DynamicFun closure sv)   | otherwise = do       (e, sv) <- defuncFun dims ps body (mempty, rettype) noLoc       return ([], [], e, sv) -defuncLet _ [] body (Info rettype) = do+defuncLet _ [] body rettype = do   (body', sv) <- defuncExp body-  return ([], [], body', imposeType sv rettype )+  return ([], [], body', imposeType sv rettype)   where imposeType Dynamic{} t =           Dynamic $ fromStruct t         imposeType (RecordSV fs1) (Scalar (Record fs2)) =@@ -491,7 +539,7 @@ -- but a new lifted function is created if a dynamic function is only partially -- applied. defuncApply :: Int -> Exp -> DefM (Exp, StaticVal)-defuncApply depth e@(Apply e1 e2 d t@(Info ret) loc) = do+defuncApply depth e@(Apply e1 e2 d t@(Info ret, Info ext) loc) = do   let (argtypes, _) = unfoldFunType ret   (e1', sv1) <- defuncApply (depth+1) e1   (e2', sv2) <- defuncExp e2@@ -513,9 +561,14 @@           params_for_rettype = params ++ svParams sv1 ++ svParams sv2           svParams (LambdaSV _ sv_pat _ _ _) = [sv_pat]           svParams _                         = []-          rettype = buildRetType closure_env params_for_rettype e0_t $-                    anyDimShapeAnnotations $ typeOf e0'+          rettype = buildRetType closure_env params_for_rettype e0_t $ typeOf e0' +          already_bound = S.fromList dims <>+                          S.map identName (foldMap patternIdents params)+          more_dims = S.toList $+                      S.filter (`S.notMember` already_bound) $+                      foldMap patternArraySizes params+           -- Embed some information about the original function           -- into the name of the lifted function, to make the           -- result slightly more human-readable.@@ -524,24 +577,40 @@           liftedName i (Apply f _ _ _ _) =             liftedName (i+1) f           liftedName _ _ = "lifted"+       fname <- newNameFromString $ liftedName (0::Int) e1-      liftValDec fname rettype dims params e0'+      liftValDec fname rettype (dims ++ more_dims) params e0'        let t1 = toStruct $ typeOf e1'           t2 = toStruct $ typeOf e2'           fname' = qualName fname-      return (Parens (Apply (Apply (Var fname' (Info (Scalar $ Arrow mempty Unnamed (fromStruct t1) $-                                                      Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype)) loc)-                             e1' (Info Observe) (Info $ Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype) loc)-                      e2' d (Info rettype) loc) noLoc, sv)+          fname'' = Var fname' (Info (Scalar $ Arrow mempty Unnamed (fromStruct t1) $+                                      Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype))+                    loc +          -- FIXME: what if this application returns both a function+          -- and a value?+          callret | orderZero ret = (Info ret, Info ext)+                  | otherwise     = (Info rettype, Info ext)++      return (Parens (Apply (Apply fname'' e1'+                              (Info (Observe, Nothing))+                              (Info $ Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype,+                               Info [])+                              loc)+                      e2' d callret loc) noLoc, sv)+     -- If e1 is a dynamic function, we just leave the application in place,     -- but we update the types since it may be partially applied or return     -- a higher-order term.     DynamicFun _ sv ->       let (argtypes', rettype) = dynamicFunType sv argtypes-          apply_e = Apply e1' e2' d (Info $ foldFunType argtypes' rettype-                                    `setAliases` aliases ret) loc+          restype = foldFunType argtypes' rettype `setAliases` aliases ret+          -- FIXME: what if this application returns both a function+          -- and a value?+          callret | orderZero ret = (Info ret, Info ext)+                  | otherwise     = (Info restype, Info ext)+          apply_e = Apply e1' e2' d callret loc       in return (apply_e, sv)      -- Propagate the 'IntrinsicsSV' until we reach the outermost application,@@ -555,7 +624,7 @@           -- non-fully-applied intrinsic?           if null argtypes             then return (e', Dynamic $ typeOf e)-            else do (pats, body, tp) <- etaExpand e'+            else do (pats, body, tp) <- etaExpand (typeOf e') e'                     defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) noLoc       | otherwise -> return (e', IntrinsicSV) @@ -576,8 +645,11 @@         | otherwise -> do             fname <- newName $ qualLeaf qn             let (dims, pats, e0, sv') = liftDynFun sv depth+                pats_names = S.map identName $ mconcat $ map patternIdents pats+                notInPats = (`S.notMember` pats_names)+                dims' = filter notInPats dims                 (argtypes', rettype) = dynamicFunType sv' argtypes-            liftValDec fname (fromStruct rettype) dims pats e0+            liftValDec fname (fromStruct rettype) dims' pats e0             return (Var (qualName fname)                     (Info (foldFunType argtypes' $ fromStruct rettype)) loc, sv') @@ -605,7 +677,7 @@ liftDynFun (DynamicFun (e, sv) _) 0 = ([], [], e, sv) liftDynFun (DynamicFun clsr@(_, LambdaSV dims pat _ _ _) sv) d   | d > 0 =  let (dims', pats, e', sv') = liftDynFun sv (d-1)-             in (dims ++ dims', pat : pats, e', DynamicFun clsr sv')+             in (nub $ dims ++ dims', pat : pats, e', DynamicFun clsr sv') liftDynFun sv _ = error $ "Tried to lift a StaticVal " ++ show sv                        ++ ", but expected a dynamic function." @@ -639,12 +711,22 @@ liftValDec :: VName -> PatternType -> [VName] -> [Pattern] -> Exp -> DefM () liftValDec fname rettype dims pats body = tell $ Seq.singleton dec   where dims' = map (flip TypeParamDim noLoc) dims-        rettype_st = anyDimShapeAnnotations $ toStruct rettype+        -- FIXME: this pass is still not correctly size-preserving, so+        -- forget those return sizes that we forgot to propagate along+        -- the way.  Hopefully the internaliser is conservative and+        -- will insert reshapes...+        bound_here = S.fromList dims <> S.map identName (foldMap patternIdents pats)+        anyDimIfNotBound (NamedDim v)+          | qualLeaf v `S.member` bound_here = NamedDim v+          | otherwise = AnyDim+        anyDimIfNotBound d = d+        rettype_st = first anyDimIfNotBound $ toStruct rettype+         dec = ValBind           { valBindEntryPoint = Nothing           , valBindName       = fname           , valBindRetDecl    = Nothing-          , valBindRetType    = Info rettype_st+          , valBindRetType    = Info (rettype_st, [])           , valBindTypeParams = dims'           , valBindParams     = pats           , valBindBody       = body@@ -656,8 +738,9 @@ -- binds the closed over variables. buildEnvPattern :: Env -> Pattern buildEnvPattern env = RecordPattern (map buildField $ M.toList env) noLoc-  where buildField (vn, sv) = (nameFromString (pretty vn),-                               Id vn (Info $ anyDimShapeAnnotations $ typeFromSV sv) noLoc)+  where buildField (vn, sv) =+          (nameFromString (pretty vn),+           Id vn (Info $ typeFromSV sv) noLoc)  -- | Given a closure environment pattern and the type of a term, -- construct the type of that term, where uniqueness is set to@@ -687,14 +770,17 @@  -- | Compute the corresponding type for a given static value. typeFromSV :: StaticVal -> PatternType-typeFromSV (Dynamic tp)           = anyDimShapeAnnotations tp-typeFromSV (LambdaSV _ _ _ _ env) = typeFromEnv env-typeFromSV (RecordSV ls)          = Scalar $ Record $ M.fromList $ map (fmap typeFromSV) ls-typeFromSV (DynamicFun (_, sv) _) = typeFromSV sv+typeFromSV (Dynamic tp) = tp+typeFromSV (LambdaSV sizes _ _ _ env) =+  unscopeType (S.fromList sizes) $ typeFromEnv env+typeFromSV (RecordSV ls) =+  Scalar $ Record $ M.fromList $ map (fmap typeFromSV) ls+typeFromSV (DynamicFun (_, sv) _) =+  typeFromSV sv typeFromSV (SumSV name svs fields) =   Scalar $ Sum $ M.insert name (map typeFromSV svs) $ M.fromList fields-typeFromSV IntrinsicSV            = error $ "Tried to get the type from the "-                                         ++ "static value of an intrinsic."+typeFromSV IntrinsicSV =+  error "Tried to get the type from the static value of an intrinsic."  typeFromEnv :: Env -> PatternType typeFromEnv = Scalar . Record . M.fromList .@@ -790,7 +876,7 @@ svFromType t                    = Dynamic t  -- A set of names where we also track uniqueness.-newtype NameSet = NameSet (M.Map VName Uniqueness)+newtype NameSet = NameSet (M.Map VName Uniqueness) deriving (Show)  instance Semigroup NameSet where   NameSet x <> NameSet y = NameSet $ M.unionWith max x y@@ -828,15 +914,17 @@     where freeVarsField (RecordFieldExplicit _ e _)  = freeVars e           freeVarsField (RecordFieldImplicit vn t _) = ident $ Ident vn t noLoc -  ArrayLit es _ _      -> foldMap freeVars es+  ArrayLit es t _      -> foldMap freeVars es <>+                          names (typeDimNames $ unInfo t)   Range e me incl _ _  -> freeVars e <> foldMap freeVars me <>                           foldMap freeVars incl   Var qn (Info t) _    -> NameSet $ M.singleton (qualLeaf qn) $ uniqueness t-  Ascript e t _ _      -> freeVars e <> names (typeDimNames $ unInfo $ expandedType t)+  Ascript e t _        -> freeVars e <> names (typeDimNames $ unInfo $ expandedType t)+  Coerce e t _ _       -> freeVars e <> names (typeDimNames $ unInfo $ expandedType t)   LetPat pat e1 e2 _ _ -> freeVars e1 <> ((names (patternDimNames pat) <> freeVars e2)                                           `without` patternVars pat) -  LetFun vn (_, pats, _, _, e1) e2 _ ->+  LetFun vn (_, pats, _, _, e1) e2 _ _ ->     ((freeVars e1 <> names (foldMap patternDimNames pats))       `without` foldMap patternVars pats) <>     (freeVars e2 `without` oneName vn)@@ -852,15 +940,17 @@   ProjectSection{}            -> mempty   IndexSection idxs _ _       -> foldMap freeDimIndex idxs -  DoLoop pat e1 form e3 _ -> let (e2fv, e2ident) = formVars form-                             in freeVars e1 <> e2fv <>-                             (freeVars e3 `without` (patternVars pat <> e2ident))+  DoLoop sparams pat e1 form e3 _ _ ->+    let (e2fv, e2ident) = formVars form+    in freeVars e1 <> e2fv <>+       (freeVars e3 `without`+        (names (S.fromList sparams) <> patternVars pat <> e2ident))     where formVars (For v e2) = (freeVars e2, ident v)           formVars (ForIn p e2)   = (freeVars e2, patternVars p)           formVars (While e2)     = (freeVars e2, mempty) -  BinOp (qn, _) _ (e1, _) (e2, _) _ _ -> oneName (qualLeaf qn) <>-                                         freeVars e1 <> freeVars e2+  BinOp (qn, _) _ (e1, _) (e2, _) _ _ _ -> oneName (qualLeaf qn) <>+                                           freeVars e1 <> freeVars e2   Project _ e _ _                -> freeVars e    LetWith id1 id2 idxs e1 e2 _ _ ->@@ -894,25 +984,21 @@ defuncValBind :: ValBind -> DefM (ValBind, Env, Bool)  -- Eta-expand entry points with a functional return type.-defuncValBind (ValBind entry@Just{} name _ (Info rettype) tparams params body _ loc)-  | (rettype_ps, rettype') <- unfoldFunType rettype,-    not $ null rettype_ps = do-      (body_pats, body', _) <- etaExpand body+defuncValBind (ValBind entry name _ (Info (rettype, retext)) tparams params body _ loc)+  | Scalar Arrow{} <- rettype = do+      (body_pats, body', rettype') <- etaExpand (fromStruct rettype) body       -- FIXME: we should also handle non-constant size annotations       -- here.       defuncValBind $ ValBind entry name Nothing-        (Info $ onlyConstantDims rettype')+        (Info (rettype', retext))         tparams (params <> body_pats) body' Nothing loc-  where onlyConstantDims = first onDim-        onDim (ConstDim x) = ConstDim x-        onDim _            = AnyDim -defuncValBind valbind@(ValBind _ name retdecl rettype tparams params body _ _) = do+defuncValBind valbind@(ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ _) = do   (tparams', params', body', sv) <- defuncLet tparams params body rettype-  let rettype' = anyDimShapeAnnotations $ toStruct $ typeOf body'+  let rettype' = anySizes $ toStruct $ typeOf body'   return ( valbind { valBindRetDecl    = retdecl-                   , valBindRetType    = Info $ combineTypeShapes-                                         (unInfo rettype) rettype'+                   , valBindRetType    = Info (combineTypeShapes rettype rettype',+                                               retext)                    , valBindTypeParams = tparams'                    , valBindParams     = params'                    , valBindBody       = body'
src/Futhark/Internalise/Defunctorise.hs view
@@ -230,14 +230,14 @@ transformExp = transformNames  transformValBind :: ValBind -> TransformM ()-transformValBind (ValBind entry name tdecl (Info t) tparams params e doc loc) = do+transformValBind (ValBind entry name tdecl (Info (t, retext)) tparams params e doc loc) = do   name' <- transformName name   tdecl' <- traverse transformTypeExp tdecl   t' <- transformStructType t   e' <- transformExp e   tparams' <- traverse transformNames tparams   params' <- traverse transformNames params-  emit $ ValDec $ ValBind entry name' tdecl' (Info t') tparams' params' e' doc loc+  emit $ ValDec $ ValBind entry name' tdecl' (Info (t', retext)) tparams' params' e' doc loc  transformTypeDecl :: TypeDecl -> TransformM TypeDecl transformTypeDecl (TypeDecl dt (Info et)) =
src/Futhark/Internalise/Lambdas.hs view
@@ -57,8 +57,9 @@       outer = (`setOuterSize` I.Var chunk_size)   localScope (scopeOfLParams [chunk_param]) $ do     argtypes <- mapM I.subExpType args-    (orig_chunk_param : params, orig_body, rettype) <-+    (lam_params, orig_body, rettype) <-       internaliseLambda lam $ I.Prim int32 : map outer argtypes+    let orig_chunk_param : params = lam_params     body <- runBodyBinder $ do       letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size       return orig_body@@ -106,8 +107,8 @@       let sizefun_safe =             all (I.safeExp . I.stmExp) $ I.bodyStms $ I.lambdaBody sizefun'           sizefun_arg_invariant =-            not $ any (`nameIn` freeIn (I.lambdaBody sizefun')) $-            map I.paramName $ lambdaParams sizefun'+            not $ any ((`nameIn` freeIn (I.lambdaBody sizefun')) . I.paramName) $+            lambdaParams sizefun'       if sizefun_safe && sizefun_arg_invariant         then do ses <- bodyBind $ lambdaBody sizefun'                 forM_ (zip inner_shapes ses) $ \(v, se) ->@@ -152,8 +153,9 @@   let chunk_param = I.Param chunk_size $ I.Prim int32       chunktypes = map (`arrayOfRow` I.Var chunk_size) rowts   localScope (scopeOfLParams [chunk_param]) $ do-    (orig_chunk_param : params, orig_body, _) <-+    (lam_params, orig_body, _) <-       internaliseLambda lam $ I.Prim int32 : chunktypes+    let orig_chunk_param : params = lam_params     body <- runBodyBinder $ do       letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size       return orig_body@@ -188,5 +190,5 @@          lambdaWithIncrement :: I.Body -> InternaliseM I.Body         lambdaWithIncrement lam_body = runBodyBinder $ do-          [eq_class] <- bodyBind lam_body+          eq_class <- head <$> bodyBind lam_body           resultBody <$> mkResult eq_class 0
src/Futhark/Internalise/Monad.hs view
@@ -15,6 +15,7 @@   , lookupFunction   , lookupFunction'   , lookupConst+  , topLevelSizes    , bindFunction   , bindConstant@@ -40,7 +41,6 @@ import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.RWS-import qualified Control.Monad.Fail as Fail import qualified Data.Map.Strict as M  import Futhark.Representation.SOACS@@ -60,7 +60,10 @@  type FunTable = M.Map VName FunInfo -type ConstInfo = (Name, ConstParams, [(SubExp,Type)] -> Maybe [DeclExtType])+type ConstInfo = (Name, ConstParams,+                  [(SubExp,Type)] -> Maybe [DeclExtType],+                  [SubExp] -> InternaliseM (),+                  Names)  type ConstTable = M.Map VName ConstInfo @@ -78,6 +81,7 @@     stateNameSource :: VNameSource   , stateFunTable :: FunTable   , stateConstTable :: ConstTable+  , stateTopLevelSizes :: Names   }  newtype InternaliseResult = InternaliseResult [FunDef SOACS]@@ -100,9 +104,6 @@   getNameSource = gets stateNameSource   putNameSource src = modify $ \s -> s { stateNameSource = src } -instance Fail.MonadFail InternaliseM where-  fail = error . ("InternaliseM: "++)- instance MonadBinder InternaliseM where   type Lore InternaliseM = SOACS   mkExpAttrM pat e = InternaliseM $ mkExpAttrM pat e@@ -130,6 +131,7 @@           InternaliseState { stateNameSource = src                            , stateFunTable = mempty                            , stateConstTable = mempty+                           , stateTopLevelSizes = mempty                            }  substitutingVars :: VarSubstitutions -> InternaliseM a -> InternaliseM a@@ -144,7 +146,7 @@  lookupFunction :: VName -> InternaliseM FunInfo lookupFunction fname = maybe bad return =<< lookupFunction' fname-  where bad = fail $ "Internalise.lookupFunction: Function '" ++ pretty fname ++ "' not found."+  where bad = error $ "Internalise.lookupFunction: Function '" ++ pretty fname ++ "' not found."  lookupConst :: VName -> InternaliseM (Maybe ConstInfo) lookupConst fname = gets $ M.lookup fname . stateConstTable@@ -156,6 +158,13 @@ bindConstant :: VName -> ConstInfo -> InternaliseM () bindConstant cname info =   modify $ \s -> s { stateConstTable = M.insert cname info $ stateConstTable s }++-- | Size names implicitly created by existential top-level constant+-- definitions.  These need special treatment because such a thing+-- does not exist in the core language.+topLevelSizes :: InternaliseM Names+topLevelSizes = gets $ foldMap sizes . stateConstTable+  where sizes (_, _, _, _, x) = x  -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list.
src/Futhark/Internalise/Monomorphise.hs view
@@ -32,6 +32,7 @@ import           Control.Monad.Writer hiding (Sum) import           Data.Bitraversable import           Data.Bifunctor+import           Data.List import           Data.Loc import qualified Data.Map.Strict as M import           Data.Maybe@@ -45,6 +46,9 @@ import           Language.Futhark.Semantic (TypeBinding(..)) import           Language.Futhark.TypeChecker.Types +i32 :: TypeBase dim als+i32 = Scalar $ Prim $ Signed Int32+ -- | The monomorphization monad reads 'PolyBinding's and writes 'ValBinding's. -- The 'TypeParam's in a 'ValBinding' can only be shape parameters. --@@ -53,7 +57,7 @@ -- in local functions. data PolyBinding = PolyBinding RecordReplacements                    (VName, [TypeParam], [Pattern],-                     Maybe (TypeExp VName), StructType, Exp, SrcLoc)+                     Maybe (TypeExp VName), StructType, [VName], Exp, SrcLoc)  -- | Mapping from record names to the variable names that contain the -- fields.  This is used because the monomorphiser also expands all@@ -110,9 +114,22 @@ lookupRecordReplacement :: VName -> MonoM (Maybe RecordReplacement) lookupRecordReplacement v = asks $ M.lookup v . envRecordReplacements +-- | Given instantiated type of function, produce size arguments.+type InferSizeArgs = StructType -> [Exp]++-- | The kind of type relative to which we monomorphise.  What is+-- important to us is not the specific dimensions, but merely whether+-- they are known or anonymous (the latter False).+type MonoType = TypeBase Bool ()++monoType :: TypeBase (DimDecl VName) als -> MonoType+monoType = bimap onDim (const ())+  where onDim AnyDim = False+        onDim _      = True+ -- | Mapping from function name and instance list to a new function name in case -- the function has already been instantiated with those concrete types.-type Lifts = [((VName, TypeBase () ()), VName)]+type Lifts = [((VName, MonoType), (VName, InferSizeArgs))]  getLifts :: MonoM Lifts getLifts = MonoM $ lift get@@ -120,31 +137,49 @@ modifyLifts :: (Lifts -> Lifts) -> MonoM () modifyLifts = MonoM . lift . modify -addLifted :: VName -> TypeBase () () -> VName -> MonoM ()-addLifted fname il lifted_fname =-  modifyLifts (((fname, il), lifted_fname) :)+addLifted :: VName -> MonoType -> (VName, InferSizeArgs) -> MonoM ()+addLifted fname il liftf =+  modifyLifts (((fname, il), liftf) :) -lookupLifted :: VName -> TypeBase () () -> MonoM (Maybe VName)+lookupLifted :: VName -> MonoType -> MonoM (Maybe (VName, InferSizeArgs)) lookupLifted fname t = lookup (fname, t) <$> getLifts -transformFName :: VName -> TypeBase () () -> MonoM VName-transformFName fname t-  | baseTag fname <= maxIntrinsicTag = return fname+transformFName :: SrcLoc -> QualName VName -> StructType -> MonoM Exp+transformFName loc fname t+  | baseTag (qualLeaf fname) <= maxIntrinsicTag = return $ var fname   | otherwise = do-      maybe_fname <- lookupLifted fname t-      maybe_funbind <- lookupFun fname+      maybe_fname <- lookupLifted (qualLeaf fname) (monoType t)+      maybe_funbind <- lookupFun $ qualLeaf fname+      t' <- removeTypeVariablesInType t       case (maybe_fname, maybe_funbind) of-        -- The function has already been monomorphized.-        (Just fname', _) -> return fname'+        -- The function has already been monomorphised.+        (Just (fname', infer), _) ->+          return $ applySizeArgs fname' t' $ infer t'         -- An intrinsic function.-        (Nothing, Nothing) -> return fname+        (Nothing, Nothing) -> return $ var fname         -- A polymorphic function.         (Nothing, Just funbind) -> do-          (fname', funbind') <- monomorphizeBinding False funbind t-          tell $ Seq.singleton (fname, funbind')-          addLifted fname t fname'-          return fname'+          (fname', infer, funbind') <- monomorphiseBinding False funbind (monoType t')+          tell $ Seq.singleton (qualLeaf fname, funbind')+          addLifted (qualLeaf fname) (monoType t) (fname', infer)+          return $ applySizeArgs fname' t' $ infer t' +  where var fname' = Var fname' (Info (fromStruct t)) loc++        applySizeArg (i, f) size_arg =+          (i-1,+           Apply f size_arg (Info (Observe, Nothing))+           (Info (foldFunType (replicate i i32) (fromStruct t)), Info [])+           loc)++        applySizeArgs fname' t' size_args =+          snd $ foldl' applySizeArg (length size_args - 1,+                                     Var (qualName fname')+                                     (Info (foldFunType (map (const i32) size_args)+                                            (fromStruct t')))+                                     loc)+          size_args+ -- | This carries out record replacements in the alias information of a type. transformType :: TypeBase dim Aliasing -> MonoM (TypeBase dim Aliasing) transformType t = do@@ -183,8 +218,8 @@           transformField $ RecordFieldExplicit (baseName v)             (Var (qualName v) t' loc) loc -transformExp (ArrayLit es tp loc) =-  ArrayLit <$> mapM transformExp es <*> pure tp <*> pure loc+transformExp (ArrayLit es t loc) =+  ArrayLit <$> mapM transformExp es <*> traverse transformType t <*> pure loc  transformExp (Range e1 me incl tp loc) = do   e1' <- transformExp e1@@ -192,8 +227,8 @@   incl' <- mapM transformExp incl   return $ Range e1' me' incl' tp loc -transformExp (Var (QualName qs fname) (Info t) loc) = do-  maybe_fs <- lookupRecordReplacement fname+transformExp (Var fname (Info t) loc) = do+  maybe_fs <- lookupRecordReplacement $ qualLeaf fname   case maybe_fs of     Just fs -> do       let toField (f, (f_v, f_t)) = do@@ -202,29 +237,31 @@             return $ RecordFieldExplicit f f_v' loc       RecordLit <$> mapM toField (M.toList fs) <*> pure loc     Nothing -> do-      fname' <- transformFName fname (toStructural t)       t' <- transformType t-      return $ Var (QualName qs fname') (Info t') loc+      transformFName loc fname (toStruct t') -transformExp (Ascript e tp t loc) = do-  noticeDims $ unInfo t-  Ascript <$> transformExp e <*> pure tp <*>-    traverse transformType t <*> pure loc+transformExp (Ascript e tp loc) =+  Ascript <$> transformExp e <*> pure tp <*> pure loc -transformExp (LetPat pat e1 e2 (Info t) loc) = do+transformExp (Coerce e tp (Info t, ext) loc) = do+  noticeDims t+  Coerce <$> transformExp e <*> pure tp <*>+    ((,) <$> (Info <$> transformType t) <*> pure ext) <*> pure loc++transformExp (LetPat pat e1 e2 (Info t, retext) loc) = do   (pat', rr) <- transformPattern pat   t' <- transformType t   LetPat pat' <$> transformExp e1 <*>     withRecordReplacements rr (transformExp e2) <*>-    pure (Info t') <*> pure loc+    pure (Info t', retext) <*> pure loc -transformExp (LetFun fname (tparams, params, retdecl, Info ret, body) e loc)+transformExp (LetFun fname (tparams, params, retdecl, Info ret, body) e e_t loc)   | any isTypeParam tparams = do       -- Retrieve the lifted monomorphic function bindings that are produced,       -- filter those that are monomorphic versions of the current let-bound       -- function and insert them at this point, and propagate the rest.       rr <- asks envRecordReplacements-      let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, body, loc)+      let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, [], body, loc)       pass $ do         (e', bs) <- listen $ extendEnv fname funbind $ transformExp e         let (bs_local, bs_prop) = Seq.partition ((== fname) . fst) bs@@ -233,20 +270,20 @@   | otherwise = do       body' <- transformExp body       LetFun fname (tparams, params, retdecl, Info ret, body') <$>-        transformExp e <*> pure loc+        transformExp e <*> traverse transformType e_t <*> pure loc -transformExp (If e1 e2 e3 tp loc) = do+transformExp (If e1 e2 e3 (tp, retext) loc) = do   e1' <- transformExp e1   e2' <- transformExp e2   e3' <- transformExp e3   tp' <- traverse transformType tp-  return $ If e1' e2' e3' tp' loc+  return $ If e1' e2' e3' (tp', retext) loc -transformExp (Apply e1 e2 d tp loc) = do+transformExp (Apply e1 e2 d (ret, ext) loc) = do   e1' <- transformExp e1   e2' <- transformExp e2-  tp' <- traverse transformType tp-  return $ Apply e1' e2' d tp' loc+  ret' <- traverse transformType ret+  return $ Apply e1' e2' d (ret', ext) loc  transformExp (Negate e loc) =   Negate <$> transformExp e <*> pure loc@@ -258,17 +295,19 @@ transformExp (OpSection qn t loc) =   transformExp $ Var qn t loc -transformExp (OpSectionLeft (QualName qs fname) (Info t) e-               (Info xtype, Info ytype) (Info rettype) loc) = do-  fname' <- transformFName fname (toStructural t)+transformExp (OpSectionLeft fname (Info t) e+               (Info (xtype, xargext), Info ytype) (Info rettype, Info retext) loc) = do+  fname' <- transformFName loc fname $ toStruct t   e' <- transformExp e-  desugarBinOpSection (QualName qs fname') (Just e') Nothing t xtype ytype rettype loc+  desugarBinOpSection fname' (Just e') Nothing+    t (xtype, xargext) (ytype, Nothing) (rettype, retext) loc -transformExp (OpSectionRight (QualName qs fname) (Info t) e-               (Info xtype, Info ytype) (Info rettype) loc) = do-  fname' <- transformFName fname (toStructural t)+transformExp (OpSectionRight fname (Info t) e+              (Info xtype, Info (ytype, yargext)) (Info rettype) loc) = do+  fname' <- transformFName loc fname $ toStruct t   e' <- transformExp e-  desugarBinOpSection (QualName qs fname') Nothing (Just e') t xtype ytype rettype loc+  desugarBinOpSection fname' Nothing (Just e')+    t (xtype, Nothing) (ytype, yargext) (rettype, []) loc  transformExp (ProjectSection fields (Info t) loc) =   desugarProjectSection fields t loc@@ -276,20 +315,28 @@ transformExp (IndexSection idxs (Info t) loc) =   desugarIndexSection idxs t loc -transformExp (DoLoop pat e1 form e3 loc) = do+transformExp (DoLoop sparams pat e1 form e3 ret loc) = do   e1' <- transformExp e1   form' <- case form of     For ident e2  -> For ident <$> transformExp e2     ForIn pat2 e2 -> ForIn pat2 <$> transformExp e2     While e2      -> While <$> transformExp e2   e3' <- transformExp e3-  return $ DoLoop pat e1' form' e3' loc+  return $ DoLoop sparams pat e1' form' e3' ret loc -transformExp (BinOp (QualName qs fname, oploc) (Info t) (e1, d1) (e2, d2) tp loc) = do-  fname' <- transformFName fname (toStructural t)+transformExp (BinOp (fname, oploc) (Info t) (e1, d1) (e2, d2) tp ext loc) = do+  fname' <- transformFName loc fname $ toStruct t   e1' <- transformExp e1   e2' <- transformExp e2-  return $ BinOp (QualName qs fname', oploc) (Info t) (e1', d1) (e2', d2) tp loc+  return $+    case fname' of+      Var fname'' _ _ ->+        BinOp (fname'', oploc) (Info t) (e1', d1) (e2', d2) tp ext loc+      _ ->+        Apply (Apply fname' e1' (Info (Observe, snd (unInfo d1)))+               (Info (foldFunType [fromStruct $ fst (unInfo d2)] (unInfo tp)),+                Info mempty) loc)+        e2' (Info (Observe, snd (unInfo d2))) (tp, ext) loc  transformExp (Project n e tp loc) = do   maybe_fs <- case e of@@ -329,8 +376,9 @@ transformExp (Constr name all_es t loc) =   Constr name <$> mapM transformExp all_es <*> pure t <*> pure loc -transformExp (Match e cs t loc) =-  Match <$> transformExp e <*> mapM transformCase cs <*> traverse transformType t <*> pure loc+transformExp (Match e cs (t, retext) loc) =+  Match <$> transformExp e <*> mapM transformCase cs <*>+  ((,) <$> traverse transformType t <*> pure retext) <*> pure loc  transformCase :: Case -> MonoM Case transformCase (CasePat p e loc) = do@@ -344,12 +392,17 @@   where trans = mapM transformExp  -- | Transform an operator section into a lambda.-desugarBinOpSection :: QualName VName -> Maybe Exp -> Maybe Exp-                 -> PatternType -> StructType -> StructType -> PatternType -> SrcLoc -> MonoM Exp-desugarBinOpSection qn e_left e_right t xtype ytype rettype loc = do+desugarBinOpSection :: Exp -> Maybe Exp -> Maybe Exp+                    -> PatternType+                    -> (StructType, Maybe VName) -> (StructType, Maybe VName)+                    -> (PatternType, [VName]) -> SrcLoc -> MonoM Exp+desugarBinOpSection op e_left e_right t (xtype, xext) (ytype, yext) (rettype, retext) loc = do   (e1, p1) <- makeVarParam e_left $ fromStruct xtype   (e2, p2) <- makeVarParam e_right $ fromStruct ytype-  let body = BinOp (qn, loc) (Info t) (e1, Info xtype) (e2, Info ytype) (Info rettype) loc+  let apply_left = Apply op e1 (Info (Observe, xext))+                   (Info $ foldFunType [fromStruct ytype] t, Info []) loc+      body = Apply apply_left e2 (Info (Observe, yext))+             (Info rettype, Info retext) loc       rettype' = toStruct rettype   return $ Lambda (p1 ++ p2) body Nothing (Info (mempty, rettype')) loc @@ -376,22 +429,23 @@ desugarIndexSection :: [DimIndex] -> PatternType -> SrcLoc -> MonoM Exp desugarIndexSection idxs (Scalar (Arrow _ _ t1 t2)) loc = do   p <- newVName "index_i"-  let body = Index (Var (qualName p) (Info t1) loc) idxs (Info t2) loc+  let body = Index (Var (qualName p) (Info t1) loc) idxs (Info t2, Info []) loc   return $ Lambda [Id p (Info t1) noLoc] body Nothing (Info (mempty, toStruct t2)) loc desugarIndexSection  _ t _ = error $ "desugarIndexSection: not a function type: " ++ pretty t  noticeDims :: TypeBase (DimDecl VName) as -> MonoM () noticeDims = mapM_ notice . nestedDims-  where notice (NamedDim v) = void $ transformFName (qualLeaf v) $ Scalar $ Prim $ Signed Int32+  where notice (NamedDim v) = void $ transformFName noLoc v i32         notice _            = return ()  -- | Convert a collection of 'ValBind's to a nested sequence of let-bound, -- monomorphic functions with the given expression at the bottom. unfoldLetFuns :: [ValBind] -> Exp -> Exp unfoldLetFuns [] e = e-unfoldLetFuns (ValBind _ fname _ rettype dim_params params body _ loc : rest) e =-  LetFun fname (dim_params, params, Nothing, rettype, body) e' loc+unfoldLetFuns (ValBind _ fname _ (Info (rettype, _)) dim_params params body _ loc : rest) e =+  LetFun fname (dim_params, params, Nothing, Info rettype, body) e' (Info e_t) loc   where e' = unfoldLetFuns rest e+        e_t = typeOf e'  transformPattern :: Pattern -> MonoM (Pattern, RecordReplacements) transformPattern (Id v (Info (Scalar (Record fs))) loc) = do@@ -430,41 +484,96 @@ wildcard t loc =   Wildcard (Info t) loc --- | Monomorphize a polymorphic function at the types given in the instance--- list. Monomorphizes the body of the function as well. Returns the fresh name+type DimInst = M.Map VName (DimDecl VName)++dimMapping :: Monoid a =>+              TypeBase (DimDecl VName) a+           -> TypeBase (DimDecl VName) a+           -> DimInst+dimMapping t1 t2 = execState (matchDims f t1 t2) mempty+  where f (NamedDim d1) d2 = do+          modify $ M.insert (qualLeaf d1) d2+          return $ NamedDim d1+        f d _ = return d++inferSizeArgs :: [TypeParam] -> StructType -> StructType -> [Exp]+inferSizeArgs tparams bind_t t =+  mapMaybe (tparamArg (dimMapping bind_t t)) tparams+  where tparamArg dinst tp =+          case M.lookup (typeParamName tp) dinst of+            Just (NamedDim d) ->+              Just $ Var d (Info i32) noLoc+            Just (ConstDim x) ->+              Just $ Literal (SignedValue $ Int32Value $ fromIntegral x) noLoc+            _ ->+              Nothing++explicitSizes :: StructType -> MonoType -> S.Set VName+explicitSizes t1 t2 =+  execState (matchDims onDims t1 t2) mempty `S.intersection` mustBeExplicit t1+  where onDims d1 d2 = do+          case (d1, d2) of+            (NamedDim v, True) -> modify $ S.insert $ qualLeaf v+            _                  -> return ()+          return d1++-- Monomorphising higher-order functions can result in function types+-- where the same named parameter occurs in multiple spots.  When+-- monomorphising we don't really need those parameter names anymore,+-- and the defunctionaliser can be confused if there are duplicates+-- (it doesn't handle shadowing), so let's just remove all parameter+-- names here.  This is safe because a MonoType does not contain sizes+-- anyway.+noNamedParams :: MonoType -> MonoType+noNamedParams = f+  where f (Array () u t shape) = Array () u (f' t) shape+        f (Scalar t) = Scalar $ f' t+        f' (Arrow () _ t1 t2) =+          Arrow () Unnamed (f t1) (f t2)+        f' (Record fs) =+          Record $ fmap f fs+        f' (Sum cs) =+          Sum $ fmap (map f) cs+        f' t = t++-- | Monomorphise a polymorphic function at the types given in the instance+-- list. Monomorphises the body of the function as well. Returns the fresh name -- of the generated monomorphic function and its 'ValBind' representation.-monomorphizeBinding :: Bool -> PolyBinding -> TypeBase () () -> MonoM (VName, ValBind)-monomorphizeBinding entry (PolyBinding rr (name, tparams, params, retdecl, rettype, body, loc)) t =+monomorphiseBinding :: Bool -> PolyBinding -> MonoType+                    -> MonoM (VName, InferSizeArgs, ValBind)+monomorphiseBinding entry (PolyBinding rr (name, tparams, params, retdecl, rettype, retext, body, loc)) t =   replaceRecordReplacements rr $ do-  t' <- removeTypeVariablesInType t-  let bind_t = foldFunType (map (toStructural . patternType) params) $-               toStructural rettype-  (substs, t_shape_params) <- typeSubstsM loc bind_t t'+  let bind_t = foldFunType (map patternStructType params) rettype+  (substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams t   let substs' = M.map Subst substs       rettype' = substTypesAny (`M.lookup` substs') rettype       substPatternType =         substTypesAny (fmap (fmap fromStruct) . (`M.lookup` substs'))       params' = map (substPattern entry substPatternType) params+      bind_t' = substTypesAny (`M.lookup` substs') bind_t+      (shape_params_explicit, shape_params_implicit) =+        partition ((`S.member` explicitSizes bind_t' t) . typeParamName) $+        shape_params ++ t_shape_params    (params'', rrs) <- unzip <$> mapM transformPattern params'    mapM_ noticeDims $ rettype : map patternStructType params'' -  body' <- updateExpTypes (`M.lookup` M.map (fmap toStructural) substs') body+  body' <- updateExpTypes (`M.lookup` substs') body   body'' <- withRecordReplacements (mconcat rrs) $ transformExp body'-  body''' <- astMap noMoreSumTypes body''-  params''' <- astMap noMoreSumTypes params''-  name' <- if null tparams then return name else newName name-  return (name', toValBinding t_shape_params name' params''' rettype' body''')+  name' <- if null tparams && not entry then return name else newName name -  where shape_params = filter (not . isTypeParam) tparams+  return (name',+          inferSizeArgs shape_params_explicit bind_t',+          if entry+          then toValBinding name'+               (shape_params_explicit++shape_params_implicit) params''+               (rettype', retext) body''+          else toValBinding name' shape_params_implicit+               (map shapeParam shape_params_explicit ++ params'')+               (rettype', retext) body'') -        noMoreSumTypes = ASTMapper { mapOnExp         = pure-                                   , mapOnName        = pure-                                   , mapOnQualName    = pure-                                   , mapOnStructType  = pure-                                   , mapOnPatternType = pure-                                   }+  where shape_params = filter (not . isTypeParam) tparams          updateExpTypes substs = astMap $ mapper substs         mapper substs = ASTMapper { mapOnExp         = astMap $ mapper substs@@ -474,61 +583,57 @@                                   , mapOnPatternType = pure . applySubst substs                                   } -        toValBinding t_shape_params name' params'' rettype' body'' =+        shapeParam tp = Id (typeParamName tp) (Info i32) $ srclocOf tp++        toValBinding name' tparams' params'' rettype' body'' =           ValBind { valBindEntryPoint = Nothing                   , valBindName       = name'                   , valBindRetDecl    = retdecl                   , valBindRetType    = Info rettype'-                  , valBindTypeParams = shape_params ++ t_shape_params+                  , valBindTypeParams = tparams'                   , valBindParams     = params''                   , valBindBody       = body''                   , valBindDoc        = Nothing                   , valBindLocation   = loc                   } --- Careful not to introduce size parameters for non-positive positions--- (i.e. function parameters). typeSubstsM :: MonadFreshNames m =>-               SrcLoc -> TypeBase () () -> TypeBase () ()+               SrcLoc -> TypeBase () () -> MonoType             -> m (M.Map VName StructType, [TypeParam]) typeSubstsM loc orig_t1 orig_t2 =-  let (t1_pts, t1_rt) = unfoldFunType orig_t1-      (t2_pts, t2_rt) = unfoldFunType orig_t2-      m = do zipWithM_ (sub True) t1_pts t2_pts-             sub False t1_rt t2_rt+  let m = sub orig_t1 orig_t2   in runWriterT $ execStateT m mempty -  where sub pos t1@Array{} t2@Array{}+  where sub t1@Array{} t2@Array{}           | Just t1' <- peelArray (arrayRank t1) t1,             Just t2' <- peelArray (arrayRank t1) t2 =-              sub pos t1' t2'-        sub pos (Scalar (TypeVar _ _ v _)) t = addSubst pos v t-        sub pos (Scalar (Record fields1)) (Scalar (Record fields2)) =-          zipWithM_ (sub pos)+              sub t1' t2'+        sub (Scalar (TypeVar _ _ v _)) t = addSubst v t+        sub (Scalar (Record fields1)) (Scalar (Record fields2)) =+          zipWithM_ sub           (map snd $ sortFields fields1) (map snd $ sortFields fields2)-        sub _ (Scalar Prim{}) (Scalar Prim{}) = return ()-        sub _ (Scalar (Arrow _ _ t1a t1b)) (Scalar (Arrow _ _ t2a t2b)) = do-          sub False t1a t2a-          sub False t1b t2b-        sub pos (Scalar (Sum cs1)) (Scalar (Sum cs2)) =+        sub (Scalar Prim{}) (Scalar Prim{}) = return ()+        sub (Scalar (Arrow _ _ t1a t1b)) (Scalar (Arrow _ _ t2a t2b)) = do+          sub t1a t2a+          sub t1b t2b+        sub (Scalar (Sum cs1)) (Scalar (Sum cs2)) =           zipWithM_ typeSubstClause (sortConstrs cs1) (sortConstrs cs2)-          where typeSubstClause (_, ts1) (_, ts2) = zipWithM (sub pos) ts1 ts2-        sub pos t1@(Scalar Sum{}) t2 = sub pos t1 t2-        sub pos t1 t2@(Scalar Sum{}) = sub pos t1 t2+          where typeSubstClause (_, ts1) (_, ts2) = zipWithM sub ts1 ts2+        sub t1@(Scalar Sum{}) t2 = sub t1 t2+        sub t1 t2@(Scalar Sum{}) = sub t1 t2 -        sub _ t1 t2 = error $ unlines ["typeSubstsM: mismatched types:", pretty t1, pretty t2]+        sub t1 t2 = error $ unlines ["typeSubstsM: mismatched types:", pretty t1, pretty t2] -        addSubst pos (TypeName _ v) t = do+        addSubst (TypeName _ v) t = do           exists <- gets $ M.member v           unless exists $ do-            t' <- if pos-                  then bitraverse onDim pure t-                  else pure $ vacuousShapeAnnotations t+            t' <- bitraverse onDim pure t             modify $ M.insert v t' -        onDim () = do d <- lift $ lift $ newVName "d"-                      tell [TypeParamDim d loc]-                      return $ NamedDim $ qualName d+        onDim True = do d <- lift $ lift $ newVName "d"+                        tell [TypeParamDim d loc]+                        return $ NamedDim $ qualName d+        onDim False = return AnyDim  -- | Perform a given substitution on the types in a pattern. substPattern :: Bool -> (PatternType -> PatternType) -> Pattern -> Pattern@@ -545,12 +650,12 @@   PatternConstr n (Info tp) ps loc -> PatternConstr n (Info $ f tp) ps loc  toPolyBinding :: ValBind -> PolyBinding-toPolyBinding (ValBind _ name retdecl (Info rettype) tparams params body _ loc) =-  PolyBinding mempty (name, tparams, params, retdecl, rettype, body, loc)+toPolyBinding (ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ loc) =+  PolyBinding mempty (name, tparams, params, retdecl, rettype, retext, body, loc)  -- | Remove all type variables and type abbreviations from a value binding. removeTypeVariables :: Bool -> ValBind -> MonoM ValBind-removeTypeVariables entry valbind@(ValBind _ _ _ (Info rettype) _ pats body _ _) = do+removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _) = do   subs <- asks $ M.map TypeSub . envTypeBindings   let mapper = ASTMapper {           mapOnExp         = astMap mapper@@ -562,26 +667,26 @@    body' <- astMap mapper body -  return valbind { valBindRetType = Info $ substituteTypes subs rettype+  return valbind { valBindRetType = Info (substituteTypes subs rettype, retext)                  , valBindParams  = map (substPattern entry $ substituteTypes subs) pats                  , valBindBody    = body'                  } -removeTypeVariablesInType :: TypeBase () () -> MonoM (TypeBase () ())+removeTypeVariablesInType :: StructType -> MonoM StructType removeTypeVariablesInType t = do   subs <- asks $ M.map TypeSub . envTypeBindings-  return $ removeShapeAnnotations $ substituteTypes subs $ vacuousShapeAnnotations t+  return $ substituteTypes subs t  transformValBind :: ValBind -> MonoM Env transformValBind valbind = do-  valbind' <- toPolyBinding <$> removeTypeVariables (isJust (valBindEntryPoint valbind)) valbind+  valbind' <- toPolyBinding <$>+              removeTypeVariables (isJust (valBindEntryPoint valbind)) valbind   when (isJust $ valBindEntryPoint valbind) $ do-    t <- removeTypeVariablesInType $ removeShapeAnnotations $ foldFunType+    t <- removeTypeVariablesInType $ foldFunType          (map patternStructType (valBindParams valbind)) $-         unInfo $ valBindRetType valbind-    (name, valbind'') <- monomorphizeBinding True valbind' t+         fst $ unInfo $ valBindRetType valbind+    (name, _, valbind'') <- monomorphiseBinding True valbind' $ monoType t     tell $ Seq.singleton (name, valbind'' { valBindEntryPoint = valBindEntryPoint valbind})-    addLifted (valBindName valbind) t name   return mempty { envPolyBindings = M.singleton (valBindName valbind) valbind' }  transformTypeBind :: TypeBind -> MonoM Env@@ -592,7 +697,7 @@       tbinding = TypeAbbr l tparams tp   return mempty { envTypeBindings = M.singleton name tbinding } --- | Monomorphize a list of top-level declarations. A module-free input program+-- | Monomorphise a list of top-level declarations. A module-free input program -- is expected, so only value declarations and type declaration are accepted. transformDecs :: [Dec] -> MonoM () transformDecs [] = return ()
src/Futhark/Internalise/TypesValues.hs view
@@ -68,14 +68,14 @@                            -> InternaliseM ([[I.TypeBase ExtShape Uniqueness]],                                             ConstParams) internaliseEntryReturnType t = do-  let ts = case E.isTupleRecord t of Just tts -> tts-                                     _        -> [t]+  let ts = case E.isTupleRecord t of Just tts | not $ null tts -> tts+                                     _ -> [t]   runInternaliseTypeM $ mapM internaliseTypeM ts -internaliseType :: E.TypeBase () ()+internaliseType :: E.TypeBase (E.DimDecl VName) ()                 -> InternaliseM [I.TypeBase I.ExtShape Uniqueness] internaliseType =-  fmap fst . runInternaliseTypeM . internaliseTypeM . E.vacuousShapeAnnotations+  fmap fst . runInternaliseTypeM . internaliseTypeM  newId :: InternaliseTypeM Int newId = do (i,cm) <- get@@ -99,14 +99,13 @@              (Nothing, Nothing, Just [v]) -> return $ I.Free v -            (_, Just (fname, _, _), _) -> do+            (_, Just (fname, _, _, _, _), _) -> do               (i,cm) <- get               case find ((==fname) . fst) cm of                 Just (_, known) -> return $ I.Free $ I.Var known                 Nothing -> do new <- liftInternaliseM $ newVName $ baseString name                               put (i, (fname,new):cm)                               return $ I.Free $ I.Var new-             _ -> return $ I.Free $ I.Var name  internaliseTypeM :: E.StructType@@ -119,8 +118,12 @@       return [I.arrayOf et' (Shape dims) $ internaliseUniqueness u | et' <- ets ]     E.Scalar (E.Prim bt) ->       return [I.Prim $ internalisePrimType bt]-    E.Scalar (E.Record ets) ->-      concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets)+    E.Scalar (E.Record ets)+      -- XXX: we map empty records to bools, because otherwise+      -- arrays of unit will lose their sizes.+      | null ets -> return [I.Prim I.Bool]+      | otherwise ->+          concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets)     E.Scalar E.TypeVar{} ->       error "internaliseTypeM: cannot handle type variable."     E.Scalar E.Arrow{} ->@@ -142,8 +145,7 @@                 foldl' f (zip ts [0..], mempty, mempty) c_ts           in (ts ++ new_ts, M.insert c (i, js) mapping)           where f (ts', js, new_ts) t-                  | primType t,-                    Just (_, j) <- find ((==t) . fst) ts' =+                  | Just (_, j) <- find ((==t) . fst) ts' =                       (delete (t, j) ts',                        js ++ [j],                        new_ts)@@ -162,8 +164,8 @@  -- | How many core language values are needed to represent one source -- language value of the given type?-internalisedTypeSize :: E.TypeBase dim () -> InternaliseM Int-internalisedTypeSize = fmap length . internaliseType . E.toStructural+internalisedTypeSize :: E.TypeBase (E.DimDecl VName) () -> InternaliseM Int+internalisedTypeSize = fmap length . internaliseType  -- | Convert an external primitive to an internal primitive. internalisePrimType :: E.PrimType -> I.PrimType
src/Futhark/Optimise/Fusion/TryFusion.hs view
@@ -9,7 +9,6 @@ import Control.Applicative import Control.Monad.State import Control.Monad.Reader-import qualified Control.Monad.Fail as Fail  import Futhark.Representation.SOACS import Futhark.MonadFreshNames@@ -17,7 +16,7 @@ newtype TryFusion a = TryFusion (ReaderT (Scope SOACS)                                  (StateT VNameSource Maybe)                                  a)-  deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail,+  deriving (Functor, Applicative, Alternative, Monad, MonadFail,             MonadFreshNames,             HasScope SOACS,             LocalScope SOACS)
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -170,7 +170,7 @@        }   where pass prog = do           let cg = buildCallGraph prog-          Prog <$> aggInlining cg (progFunctions prog)+          Prog <$> aggInlining cg (progFuns prog)  -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program.@@ -182,6 +182,6 @@        }   where pass prog =           let cg        = buildCallGraph prog-              live_funs = filter (isFunInCallGraph cg) (progFunctions prog)+              live_funs = filter (isFunInCallGraph cg) (progFuns prog)           in Prog live_funs         isFunInCallGraph cg fundec = isJust $ M.lookup (funDefName fundec) cg
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -247,7 +247,7 @@   (x, stms) <- m   ops <- asks $ protectHoistedOpS . fst   runBinder $ do-    if any (not . safeExp . stmExp) stms+    if not $ all (safeExp . stmExp) stms       then do cond' <- if side then return cond                        else letSubExp "cond_neg" $ BasicOp $ UnOp Not cond               mapM_ (protectIf ops unsafeOrCostly cond') stms@@ -268,7 +268,7 @@   (x, stms) <- m   ops <- asks $ protectHoistedOpS . fst   runBinder $ do-    if any (not . safeExp . stmExp) stms+    if not $ all (safeExp . stmExp) stms       then do is_nonempty <- checkIfNonEmpty               mapM_ (protectIf ops (not . safeExp) is_nonempty) stms       else addStms stms@@ -315,7 +315,7 @@  emptyOfType :: MonadBinder m => [VName] -> Type -> m (Exp (Lore m)) emptyOfType _ Mem{} =-  fail "emptyOfType: Cannot hoist non-existential memory."+  error "emptyOfType: Cannot hoist non-existential memory." emptyOfType _ (Prim pt) =   return $ BasicOp $ SubExp $ Constant $ blankPrimValue pt emptyOfType ctx_names (Array pt shape _) = do@@ -329,7 +329,7 @@ -- further optimisation.. notWorthHoisting :: Attributes lore => BlockPred lore notWorthHoisting _ _ (Let pat _ e) =-  not (safeExp e) && any (>0) (map arrayRank $ patternTypes pat)+  not (safeExp e) && any ((>0) . arrayRank) (patternTypes pat)  hoistStms :: SimplifiableLore lore =>              RuleBook (Wise lore) -> BlockPred (Wise lore)@@ -514,6 +514,7 @@                     stmsToList $ stms1<>stms2        isNotHoistableBnd _ _ _ (Let _ _ (BasicOp ArrayLit{})) = False+      isNotHoistableBnd _ _ _ (Let _ _ (BasicOp SubExp{})) = False       isNotHoistableBnd nms _ _ stm = not (hasPatName nms stm)        block = branch_blocker `orIf`@@ -804,12 +805,16 @@   simplify (Free se) = Free <$> simplify se   simplify (Ext x)   = return $ Ext x +instance Simplifiable Space where+  simplify (ScalarSpace ds t) = ScalarSpace <$> simplify ds <*> pure t+  simplify s = pure s+ instance Simplifiable shape => Simplifiable (TypeBase shape u) where   simplify (Array et shape u) = do     shape' <- simplify shape     return $ Array et shape' u   simplify (Mem space) =-    pure $ Mem space+    Mem <$> simplify space   simplify (Prim bt) =     return $ Prim bt
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -286,7 +286,7 @@           (x,x_stms) <- collectStms m           case x of             IndexResult cs arr' slice-              | all (not . (i `nameIn`) . freeIn) x_stms,+              | not $ any ((i `nameIn`) . freeIn) x_stms,                 DimFix (Var j) : slice' <- slice,                 j == i, not $ i `nameIn` freeIn slice -> do                   addStms x_stms
src/Futhark/Optimise/Sink.hs view
@@ -81,10 +81,10 @@ optimiseBranch :: SymbolTable -> Sinking -> Body SinkLore                -> (Body SinkLore, Sunk) optimiseBranch vtable sinking (Body attr stms res) =-  let (stms', stms_sunk) = optimiseStms vtable sinking' stms+  let (stms', stms_sunk) = optimiseStms vtable sinking' stms $ freeIn res   in (Body attr (sunk_stms <> stms') res,       sunk <> stms_sunk)-  where free_in_stms = freeIn stms+  where free_in_stms = freeIn stms <> freeIn res         (sinking_here, sinking') = M.partitionWithKey sunkHere sinking         sunk_stms = stmsFromList $ M.elems sinking_here         sunkHere v stm =@@ -92,15 +92,16 @@           all (`ST.available` vtable) (namesToList (freeIn stm))         sunk = S.fromList $ concatMap (patternNames . stmPattern) sunk_stms -optimiseStms :: SymbolTable -> Sinking -> Stms SinkLore+optimiseStms :: SymbolTable -> Sinking -> Stms SinkLore -> Names              -> (Stms SinkLore, Sunk)-optimiseStms init_vtable init_sinking all_stms =+optimiseStms init_vtable init_sinking all_stms free_in_res =   let (all_stms', sunk) =         optimiseStms' init_vtable init_sinking $ stmsToList all_stms   in (stmsFromList all_stms', sunk)   where-    multiplicities = foldl' (M.unionWith (+)) mempty $-                     map multiplicity $ stmsToList all_stms+    multiplicities = foldl' (M.unionWith (+))+                     (M.fromList (zip (namesToList free_in_res) [1..]))+                     (map multiplicity $ stmsToList all_stms)      optimiseStms' _ _ [] = ([], mempty) @@ -165,13 +166,13 @@ optimiseBody :: SymbolTable -> Sinking -> Body SinkLore              -> (Body SinkLore, Sunk) optimiseBody vtable sinking (Body attr stms res) =-  let (stms', sunk) = optimiseStms vtable sinking stms+  let (stms', sunk) = optimiseStms vtable sinking stms $ freeIn res   in (Body attr stms' res, sunk)  optimiseKernelBody :: SymbolTable -> Sinking -> KernelBody SinkLore                    -> (KernelBody SinkLore, Sunk) optimiseKernelBody vtable sinking (KernelBody attr stms res) =-  let (stms', sunk) = optimiseStms vtable sinking stms+  let (stms', sunk) = optimiseStms vtable sinking stms $ freeIn res   in (KernelBody attr stms' res, sunk)  optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels)
src/Futhark/Optimise/TileLoops.hs view
@@ -22,7 +22,7 @@  tileLoops :: Pass Kernels Kernels tileLoops = Pass "tile loops" "Tile stream loops inside kernels" $-            fmap Prog . mapM optimiseFunDef . progFunctions+            fmap Prog . mapM optimiseFunDef . progFuns  optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels) optimiseFunDef fundec = do@@ -86,8 +86,8 @@       -- 1D tiling of redomap.       | (gtid, kdim) : top_space_rev <- reverse $ unSegSpace initial_space,         Just (w, arrs, form) <- tileable stm_to_tile,-        all (not . nameIn gtid .-             flip (M.findWithDefault mempty) variance) arrs,+        not $ any (nameIn gtid .+                   flip (M.findWithDefault mempty) variance) arrs,         not $ gtid `nameIn` branch_variant,         (prestms', poststms') <-           preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms),@@ -273,7 +273,7 @@          mergeinit' <-           fmap (map Var) $ certifying (stmAuxCerts aux) $-          tilingSegMap tiling "tiled_loopinit" (scalarLevel tiling) ResultNoSimplify $+          tilingSegMap tiling "tiled_loopinit" (scalarLevel tiling) ResultPrivate $           \in_bounds slice ->             fmap (map Var) $ protectOutOfBounds "loopinit" in_bounds merge_ts $ do             addPrivStms slice inloop_privstms@@ -304,7 +304,7 @@ doPrelude :: Tiling -> Stms Kernels -> [VName] -> Binder Kernels [VName] doPrelude tiling prestms prestms_live =   -- Create a SegMap that takes care of the prelude for every thread.-  tilingSegMap tiling "prelude" (scalarLevel tiling) ResultMaySimplify $+  tilingSegMap tiling "prelude" (scalarLevel tiling) ResultPrivate $   \in_bounds _slice -> do     ts <- mapM lookupType prestms_live     fmap (map Var) $ letTupExp "pre" =<<@@ -399,7 +399,7 @@  scalarLevel :: Tiling -> SegLevel scalarLevel tiling =-  SegThreadScalar (segNumGroups lvl) (segGroupSize lvl) SegNoVirt+  SegThread (segNumGroups lvl) (segGroupSize lvl) SegNoVirt   where lvl = tilingLevel tiling  protectOutOfBounds :: String -> PrimExp VName -> [Type] -> Binder Kernels [SubExp]@@ -412,15 +412,19 @@                 -> Stms Kernels -> Result -> [Type]                 -> Binder Kernels [VName] postludeGeneric tiling privstms pat accs' poststms poststms_res res_ts =-  tilingSegMap tiling "thread_res" (scalarLevel tiling) ResultMaySimplify $ \in_bounds slice -> do+  tilingSegMap tiling "thread_res" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> do     -- Read our per-thread result from the tiled loop.     forM_ (zip (patternNames pat) accs') $ \(us, everyone) ->       letBindNames_ [us] $ BasicOp $ Index everyone slice      if poststms == mempty-      then return poststms_res-      else fmap (map Var) $ protectOutOfBounds "postlude" in_bounds res_ts $ do+      then do -- The privstms may still be necessary for the result.       addPrivStms slice privstms+      return poststms_res++      else+      fmap (map Var) $ protectOutOfBounds "postlude" in_bounds res_ts $ do+      addPrivStms slice privstms       addStms poststms       return poststms_res @@ -453,7 +457,7 @@        -- We don't use a Replicate here, because we want to enforce a       -- scalar memory space.-      mergeinits <- tilingSegMap tiling "mergeinit" (scalarLevel tiling) ResultNoSimplify $ \in_bounds slice ->+      mergeinits <- tilingSegMap tiling "mergeinit" (scalarLevel tiling) ResultPrivate $ \in_bounds slice ->         -- Constant neutral elements (a common case) do not need protection from OOB.         if freeIn red_nes == mempty           then return red_nes@@ -588,7 +592,7 @@    let tile = map fst tiles_and_perm -  segMap1D "acc" (SegThreadScalar num_groups group_size SegNoVirt) ResultMaySimplify $ \ltid -> do+  segMap1D "acc" (SegThread num_groups group_size SegNoVirt) ResultPrivate $ \ltid -> do      reconstructGtids1D group_size gtid gid ltid     addPrivStms [DimFix $ Var ltid] privstms@@ -794,8 +798,8 @@   -- Might be truncated in case of a partial tile.   actual_tile_size <- arraysSize 0 <$> mapM (lookupType . fst) tiles_and_perms -  segMap2D "acc" (SegThreadScalar num_groups group_size SegNoVirt)-    ResultMaySimplify (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do+  segMap2D "acc" (SegThread num_groups group_size SegNoVirt)+    ResultPrivate (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do     reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y)      addPrivStms [DimFix $ Var ltid_x, DimFix $ Var ltid_y] privstms
src/Futhark/Pass.hs view
@@ -80,7 +80,7 @@                               -> Prog fromlore -> PassM (Prog tolore) intraproceduralTransformation ft prog =   either onError onSuccess <=< modifyNameSource $ \src ->-  case partitionEithers $ parMap rpar (onFunction src) (progFunctions prog) of+  case partitionEithers $ parMap rpar (onFunction src) (progFuns prog) of     ([], rs) -> let (funs, logs, srcs) = unzip3 rs                 in (Right (Prog funs, mconcat logs), mconcat srcs)     ((err,log,src'):_, _) -> (Left (err, log), src')
src/Futhark/Pass/ExpandAllocations.hs view
@@ -36,7 +36,7 @@ expandAllocations :: Pass ExplicitMemory ExplicitMemory expandAllocations =   Pass "expand allocations" "Expand allocations" $-  fmap Prog . mapM transformFunDef . progFunctions+  fmap Prog . mapM transformFunDef . progFuns   -- Cannot use intraproceduralTransformation because it might create   -- duplicate size keys (which are not fixed by renamer, and size   -- keys must currently be globally unique).@@ -202,15 +202,18 @@ extractStmAllocations :: Names -> Stm ExplicitMemory                       -> Writer Extraction (Maybe (Stm ExplicitMemory)) extractStmAllocations bound_outside (Let (Pattern [] [patElem]) _ (Op (Alloc size space)))-  | space `notElem`-    [Space "private", Space "local"] ++-    map Space (M.keys allScalarMemory),+  | expandable space,     visibleOutside size = do       tell $ M.singleton (patElemName patElem) (size, space)       return Nothing          where visibleOutside (Var v) = v `nameIn` bound_outside               visibleOutside Constant{} = True++              expandable (Space "private") = False+              expandable (Space "local") = False+              expandable ScalarSpace{} = False+              expandable _ = True  extractStmAllocations bound_outside stm = do   e <- mapExpM expMapper $ stmExp stm
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -18,8 +18,8 @@ import Control.Monad.RWS.Strict import qualified Data.Map.Strict as M import qualified Data.Set as S-import qualified Control.Monad.Fail as Fail import Data.Maybe+import Data.List (zip4, partition, sort)  import Futhark.Representation.Kernels import Futhark.Optimise.Simplify.Lore@@ -141,9 +141,6 @@              LocalScope tolore,              MonadReader (AllocEnv fromlore tolore)) -instance Fail.MonadFail (AllocM fromlore tolore) where-  fail = error . ("AllocM.fail: "++)- instance (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>          MonadBinder (AllocM fromlore tolore) where   type Lore (AllocM fromlore tolore) = tolore@@ -253,7 +250,7 @@                        [AllocStm]) allocsForPattern sizeidents validents rts hints = do   let sizes' = [ PatElem size $ MemPrim int32 | size <- map identName sizeidents ]-  (vals, (mems, postbnds)) <-+  (vals, (exts, mems, postbnds)) <-     runWriterT $ forM (zip3 validents rts hints) $ \(ident, rt, hint) -> do       let shape = arrayShape $ identType ident       case rt of@@ -265,32 +262,74 @@           return $ PatElem (identName ident) $           MemMem space -        MemArray bt _ u (Just (ReturnsInBlock mem ixfun)) ->-          PatElem (identName ident) . MemArray bt shape u .-          ArrayIn mem <$> instantiateIxFun ixfun+        MemArray bt _ u (Just (ReturnsInBlock mem extixfun)) -> do+          (patels, ixfn) <- instantiateExtIxFun ident extixfun+          tell (patels, [], []) +          return $ PatElem (identName ident) $+            MemArray bt shape u $+            ArrayIn mem ixfn+         MemArray _ extshape _ Nothing           | Just _ <- knownShape extshape -> do             summary <- lift $ summaryForBindage (identType ident) hint             return $ PatElem (identName ident) summary -        MemArray bt _ u ret -> do-          space <- case ret of-                     Just (ReturnsNewBlock mem_space _ _) -> return mem_space-                     _                                    -> lift askDefaultSpace-          (mem,(ident',ixfun)) <- lift $ memForBindee ident space-          tell ([PatElem (identName mem) $ MemMem space],-                [])-          return $ PatElem (identName ident') $ MemArray bt shape u $-            ArrayIn (identName mem) ixfun+        MemArray bt _ u (Just (ReturnsNewBlock space _ extixfn)) -> do+          -- treat existential index function first+          (patels, ixfn) <- instantiateExtIxFun ident extixfn+          tell (patels, [], []) -  return (sizes' <> mems,+          memid <- lift $ mkMemIdent ident space+          tell ([], [PatElem (identName memid) $ MemMem space], [])+          return $ PatElem (identName ident) $ MemArray bt shape u $+            ArrayIn (identName memid) ixfn++        _ -> error "Impossible case reached in allocsForPattern!"++  return (sizes' <> exts <> mems,           vals,           postbnds)   where knownShape = mapM known . shapeDims         known (Free v) = Just v         known Ext{} = Nothing +        mkMemIdent :: (MonadFreshNames m) => Ident -> Space -> m Ident+        mkMemIdent ident space = do+          let memname = baseString (identName ident) <> "_mem"+          newIdent memname $ Mem space++        instantiateExtIxFun :: MonadFreshNames m =>+                               Ident -> ExtIxFun ->+                               m ([PatElemT (MemInfo d u ret)], IxFun)+        instantiateExtIxFun idd ext_ixfn = do+          let isAndPtps = S.toList $+                          foldMap onlyExts $+                          foldMap leafExpTypes ext_ixfn++          -- Find the existentials that reuse the sizeidents, and+          -- those that need new pattern elements.  Assumes that the+          -- Exts form a contiguous interval of integers.+          let (size_exts, new_exts) =+                span ((<length sizeidents) . fst) $ sort isAndPtps+          (new_substs, patels) <-+            fmap unzip $ forM new_exts $ \(i, t) -> do+            v <- newVName $ baseString (identName idd) <> "_ixfn"+            return ((Ext i, LeafExp (Free v) t),+                    PatElem v $ MemPrim t)+          let size_substs = zipWith (\(i, t) ident ->+                                    (Ext i, LeafExp (Free (identName ident)) t))+                            size_exts sizeidents+              substs = M.fromList $ new_substs <> size_substs+          ixfn <- instantiateIxFun $ IxFun.substituteInIxFun substs ext_ixfn++          return (patels, ixfn)++onlyExts :: (Ext a, PrimType) -> S.Set (Int, PrimType)+onlyExts (Free _, _) = S.empty+onlyExts (Ext i, t) = S.singleton (i, t)++ instantiateIxFun :: Monad m => ExtIxFun -> m IxFun instantiateIxFun = traverse $ traverse inst   where inst Ext{} = error "instantiateIxFun: not yet"@@ -314,16 +353,12 @@   m <- allocateMemory "mem" bytes space   return $ MemArray bt (arrayShape t) NoUniqueness $ ArrayIn m ixfun -memForBindee :: (MonadFreshNames m) =>-                Ident -> Space-             -> m (Ident,-                   (Ident, IxFun))-memForBindee ident space = do-  mem <- newIdent memname (Mem space)-  return (mem,-          (ident, IxFun.iota $ map (primExpFromSubExp int32) $ arrayDims t))-  where  memname = baseString (identName ident) <> "_mem"-         t       = identType ident+lookupMemSpace :: (HasScope lore m, Monad m) => VName -> m Space+lookupMemSpace v = do+  t <- lookupType v+  case t of+    Mem space -> return space+    _ -> error $ "lookupMemSpace: " ++ pretty v ++ " is not a memory block."  directIndexFunction :: PrimType -> Shape -> u -> VName -> Type -> MemBound u directIndexFunction bt shape u mem t =@@ -383,7 +418,7 @@   where allocInMergeParam (mergeparam, Var v)           | Array bt shape u <- paramDeclType mergeparam = do               (mem, ixfun) <- lift $ lookupArraySummary v-              Mem space <- lift $ lookupType mem+              space <- lift $ lookupMemSpace mem               reuse <- asks aggressiveReuse               if space /= Space "local" &&                  reuse &&@@ -409,7 +444,7 @@                  Type -> VName -> IxFun -> SubExp               -> AllocM fromlore tolore SubExp ensureArrayIn _ _ _ (Constant v) =-  fail $ "ensureArrayIn: " ++ pretty v ++ " cannot be an array."+  error $ "ensureArrayIn: " ++ pretty v ++ " cannot be an array." ensureArrayIn t mem ixfun (Var v) = do   (src_mem, src_ixfun) <- lookupArraySummary v   if src_mem == mem && src_ixfun == ixfun@@ -426,7 +461,7 @@                      Maybe Space -> VName -> AllocM fromlore tolore (VName, SubExp) ensureDirectArray space_ok v = do   (mem, ixfun) <- lookupArraySummary v-  Mem mem_space <- lookupType mem+  mem_space <- lookupMemSpace mem   default_space <- askDefaultSpace   if IxFun.isDirect ixfun && maybe True (==mem_space) space_ok     then return (mem, Var v)@@ -510,7 +545,7 @@ handleHostOp (SizeOp op) =   return $ Inner $ SizeOp op handleHostOp (OtherOp op) =-  fail $ "Cannot allocate memory in SOAC: " ++ pretty op+  error $ "Cannot allocate memory in SOAC: " ++ pretty op handleHostOp (SegOp op) =   Inner . SegOp <$> handleSegOp op @@ -528,7 +563,6 @@                                        , aggressiveReuse = True                                        }   where space = case lvl of SegThread{} -> DefaultSpace-                            SegThreadScalar{} -> DefaultSpace                             SegGroup{} -> Space "local"  bodyReturnMemCtx :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>@@ -554,14 +588,17 @@     return $ Body () (bnds'<>allocs) res''   where num_vals = length space_oks         space_oks' = replicate (length res - num_vals) Nothing ++ space_oks-        ensureDirect _ se@Constant{} = return se-        ensureDirect space_ok (Var v) = do-          bt <- primType <$> lookupType v-          if bt-            then return $ Var v-            else do (_, v') <- ensureDirectArray space_ok v-                    return v' +ensureDirect :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>+                Maybe Space -> SubExp -> AllocM fromlore tolore SubExp+ensureDirect _ se@Constant{} = return se+ensureDirect space_ok (Var v) = do+  bt <- primType <$> lookupType v+  if bt+    then return $ Var v+    else do (_, v') <- ensureDirectArray space_ok v+            return v'+ allocInStms :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>                Stms fromlore -> (Stms tolore -> AllocM fromlore tolore a)             -> AllocM fromlore tolore a@@ -611,25 +648,67 @@ allocInExp (Apply fname args rettype loc) = do   args' <- funcallArgs args   return $ Apply fname args' (memoryInRetType rettype) loc-allocInExp (If cond tbranch fbranch (IfAttr rets ifsort)) = do-  tbranch' <- allocInFunBody (map (const Nothing) rets) tbranch-  space_oks <- mkSpaceOks (length rets) tbranch'-  fbranch' <- allocInFunBody space_oks fbranch-  let rets' = createBodyReturns rets space_oks-      res_then = bodyResult tbranch'-      res_else = bodyResult fbranch'-      size_ext = length res_then - length rets'-      (ind_ses0, r_then_else) =-        foldl (\(acc_ise,acc_ext) (r_then, r_else, i) ->-                if r_then == r_else then ((i,r_then):acc_ise, acc_ext)-                else (acc_ise, (r_then, r_else):acc_ext)-              ) ([],[]) $ reverse $ zip3 res_then res_else [0..size_ext-1]-      (r_then_ext, r_else_ext) = unzip r_then_else-      ind_ses = zipWith (\(i,se) k -> (i-k,se)) ind_ses0 [0..length ind_ses0 - 1]-      rets'' = foldl (\acc (i,se) -> fixExt i se acc) rets' ind_ses-      tbranch'' = tbranch' { bodyResult = r_then_ext ++ drop size_ext res_then }-      fbranch'' = fbranch' { bodyResult = r_else_ext ++ drop size_ext res_else }-  return $ If cond tbranch'' fbranch'' $ IfAttr rets'' ifsort+allocInExp (If cond tbranch0 fbranch0 (IfAttr rets ifsort)) = do+  let num_rets = length rets+  -- switch to the explicit-mem rep, but do nothing about results+  (tbranch, tm_ixfs) <- allocInIfBody num_rets tbranch0+  (fbranch, fm_ixfs) <- allocInIfBody num_rets fbranch0+  tspaces <- mkSpaceOks num_rets tbranch+  fspaces <- mkSpaceOks num_rets fbranch+  -- try to generalize (antiunify) the index functions of the then and else bodies+  let sp_substs = zipWith generalize (zip tspaces tm_ixfs) (zip fspaces fm_ixfs)+      (spaces, subs) = unzip sp_substs+      tsubs = map (selectSub fst) subs+      fsubs = map (selectSub snd) subs+  (tbranch', trets) <- addResCtxInIfBody rets tbranch spaces tsubs+  (fbranch', frets) <- addResCtxInIfBody rets fbranch spaces fsubs+  if frets /= trets then error "In allocInExp, IF case: antiunification of then/else produce different ExtInFn!"+    else do -- above is a sanity check; implementation continues on else branch+    let res_then = bodyResult tbranch'+        res_else = bodyResult fbranch'+        size_ext = length res_then - length trets+        (ind_ses0, r_then_else) =+            partition (\(r_then, r_else, _) -> r_then == r_else) $+            zip3 res_then res_else [0 .. size_ext - 1]+        (r_then_ext, r_else_ext, _) = unzip3 r_then_else+        ind_ses = zipWith (\(se, _, i) k -> (i-k, se)) ind_ses0+                  [0 .. length ind_ses0 - 1]+        rets'' = foldl (\acc (i, se) -> fixExt i se acc) trets ind_ses+        tbranch'' = tbranch' { bodyResult = r_then_ext ++ drop size_ext res_then }+        fbranch'' = fbranch' { bodyResult = r_else_ext ++ drop size_ext res_else }+        res_if_expr = If cond tbranch'' fbranch'' $ IfAttr rets'' ifsort+    return res_if_expr+      where generalize :: (Maybe Space, Maybe MemBind) -> (Maybe Space, Maybe MemBind)+                       -> (Maybe Space, Maybe (ExtIxFun, [(PrimExp VName, PrimExp VName)]))+            generalize (Just sp1, Just (ArrayIn _ ixf1)) (Just sp2, Just (ArrayIn _ ixf2)) =+              if sp1 /= sp2 then (Just sp1, Nothing)+              else case IxFun.leastGeneralGeneralization ixf1 ixf2 of+                Just (ixf, m) -> (Just sp1, Just (ixf, m))+                Nothing -> (Just sp1, Nothing)+            generalize (mbsp1, _) _ = (mbsp1, Nothing)++            selectSub :: ((a, a) -> a) -> Maybe (ExtIxFun, [(a, a)]) ->+                         Maybe (ExtIxFun, [a])+            selectSub f (Just (ixfn, m)) = Just (ixfn, map f m)+            selectSub _ Nothing = Nothing++            -- | Just introduces the new representation (index functions); but+            -- does not unify (e.g., does not ensures direct); implementation+            -- extends `allocInBodyNoDirect`, but also return `MemBind`+            allocInIfBody :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>+                             Int -> Body fromlore -> AllocM fromlore tolore (Body tolore, [Maybe MemBind])+            allocInIfBody num_vals (Body _ bnds res) =+              allocInStms bnds $ \bnds' -> do+                let (_, val_res) = splitFromEnd num_vals res+                mem_ixfs <- mapM bodyReturnMIxf val_res+                return (Body () bnds' res, mem_ixfs)+                  where+                    bodyReturnMIxf Constant{} = return Nothing+                    bodyReturnMIxf (Var v) = do+                      info <- lookupMemInfo v+                      case info of+                        MemArray _ptp _shp _u mem_ixf -> return $ Just mem_ixf+                        _ -> return Nothing allocInExp e = mapExpM alloc e   where alloc =           identityMapper { mapOnBody = error "Unhandled Body in ExplicitAllocations"@@ -641,6 +720,79 @@                                                handle op                          } +addResCtxInIfBody :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>+                     [ExtType] -> Body tolore -> [Maybe Space] ->+                     [Maybe (ExtIxFun, [PrimExp VName])] ->+                     AllocM fromlore tolore (Body tolore, [BodyReturns])+addResCtxInIfBody ifrets (Body _ bnds res) spaces substs = do+  let num_vals = length ifrets+      (ctx_res, val_res) = splitFromEnd num_vals res+  ((res', bodyrets'), all_body_stms) <- collectStms $ do+    mapM_ addStm bnds+    (val_res', ext_ses_res, mem_ctx_res, bodyrets, total_existentials) <-+      foldM helper ([], [], [], [], length ctx_res) (zip4 ifrets val_res substs spaces)+    return (ctx_res <> ext_ses_res <> mem_ctx_res <> val_res',+             -- We need to adjust the ReturnsNewBlock existentials, because they+             -- should always be numbered _after_ all other existentials in the+             -- return values.+            reverse $ fst $ foldl adjustNewBlockExistential ([], total_existentials) bodyrets)+  body' <- mkBodyM all_body_stms res'+  return (body', bodyrets')+    where+      helper (res_acc, ext_acc, ctx_acc, br_acc, k) (ifr, r, mbixfsub, sp) =+        case mbixfsub of+          Nothing -> do+            -- does NOT generalize/antiunify; ensure direct+            r' <- ensureDirect sp r+            mem_ctx_r <- bodyReturnMemCtx r'+            let body_ret = inspect ifr sp+            return (res_acc ++ [r'],+                    ext_acc,+                    ctx_acc ++ mem_ctx_r,+                    br_acc ++ [body_ret],+                    k)+          Just (ixfn, m) -> do -- generalizes+            let i = length m+            ext_ses <- mapM (primExpToSubExp "ixfn_exist"+                             (return . BasicOp . SubExp . Var))+                       m+            mem_ctx_r <- 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' 0 ixfn'+                          _ -> error "Impossible case reached in addResCtxInIfBody"+            return (res_acc ++ [r],+                    ext_acc ++ ext_ses,+                    ctx_acc ++ mem_ctx_r,+                    br_acc ++ [exttp],+                    k + i)++      adjustNewBlockExistential :: ([BodyReturns], Int) -> BodyReturns -> ([BodyReturns], Int)+      adjustNewBlockExistential (acc, k) (MemArray pt shp u (ReturnsNewBlock space _ ixfun)) =+        (MemArray pt shp u (ReturnsNewBlock space k ixfun) : acc, k + 1)+      adjustNewBlockExistential (acc, k) x = (x : acc, k)++      inspect (Array pt shape u) space =+        let space' = fromMaybe DefaultSpace space+            bodyret = MemArray pt shape u $ ReturnsNewBlock space' 0 $+              IxFun.iota $ map convert $ shapeDims shape+        in bodyret+      inspect (Prim pt) _ = MemPrim pt+      inspect (Mem space) _ = MemMem space++      convert (Ext i) = LeafExp (Ext i) int32+      convert (Free v) = Free <$> primExpFromSubExp int32 v++      adjustExtV :: Int -> Ext VName -> Ext VName+      adjustExtV _ (Free v) = Free v+      adjustExtV k (Ext i) = Ext (k + i)++      adjustExtPE :: Int -> PrimExp (Ext VName) -> PrimExp (Ext VName)+      adjustExtPE k = fmap (adjustExtV k)+ mkSpaceOks :: (ExplicitMemorish tolore, LocalScope tolore m) =>               Int -> Body tolore -> m [Maybe Space] mkSpaceOks num_vals (Body _ stms res) =@@ -655,22 +807,6 @@                          _ -> return Nothing         mkSpaceOK _ = return Nothing -createBodyReturns :: [ExtType] -> [Maybe Space] -> [BodyReturns]-createBodyReturns ts spaces =-  evalState (zipWithM inspect ts spaces) $ S.size $ shapeContext ts-  where inspect (Array pt shape u) space = do-          i <- get <* modify (+1)-          let space' = fromMaybe DefaultSpace space-          return $ MemArray pt shape u $ ReturnsNewBlock space' i $-            IxFun.iota $ map convert $ shapeDims shape-        inspect (Prim pt) _ =-          return $ MemPrim pt-        inspect (Mem space) _ =-          return $ MemMem space--        convert (Ext i) = LeafExp (Ext i) int32-        convert (Free v) = Free <$> primExpFromSubExp int32 v- allocInLoopForm :: (Allocable fromlore tolore,                     Allocator tolore (AllocM fromlore tolore)) =>                    LoopForm fromlore -> AllocM fromlore tolore (LoopForm tolore)@@ -680,10 +816,11 @@   where allocInLoopVar (p,a) = do           (mem, ixfun) <- lookupArraySummary a           case paramType p of-            Array bt shape u ->+            Array bt shape u -> do+              dims <- map (primExpFromSubExp int32) . arrayDims <$> lookupType a               let ixfun' = IxFun.slice ixfun $-                           fullSliceNum (IxFun.shape ixfun) [DimFix $ LeafExp i int32]-              in return (p { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun' }, a)+                           fullSliceNum dims [DimFix $ LeafExp i int32]+              return (p { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun' }, a)             Prim bt ->               return (p { paramAttr = MemPrim bt }, a)             Mem space ->@@ -720,12 +857,12 @@               let t = paramType x `arrayOfRow` twice_num_threads               mem <- allocForArray t DefaultSpace               -- XXX: this iota ixfun is a bit inefficient; leading to uncoalesced access.-              let ixfun_base = IxFun.iota $-                               map (primExpFromSubExp int32) (arrayDims t)+              let base_dims = map (primExpFromSubExp int32) (arrayDims t)+                  ixfun_base = IxFun.iota base_dims                   ixfun_x = IxFun.slice ixfun_base $-                            fullSliceNum (IxFun.shape ixfun_base) [DimFix my_id]+                            fullSliceNum base_dims [DimFix my_id]                   ixfun_y = IxFun.slice ixfun_base $-                            fullSliceNum (IxFun.shape ixfun_base) [DimFix other_id]+                            fullSliceNum base_dims [DimFix other_id]               return (x { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_x },                       y { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_y })             Prim bt ->@@ -748,7 +885,6 @@ allocInKernelBody lvl (KernelBody () stms res) =   local f $ allocInStms stms $ \stms' -> return $ KernelBody () stms' res   where f = case lvl of SegThread{} -> inThread-                        SegThreadScalar{} -> inThread                         SegGroup{} -> inGroup         inThread env = env { envExpHints = inThreadExpHints }         inGroup env = env { envExpHints = inGroupExpHints }@@ -910,15 +1046,18 @@       ixfun_rearranged = IxFun.permute ixfun_base perm_inv   in ixfun_rearranged -inGroupExpHints :: Allocator ExplicitMemory m => Exp ExplicitMemory -> m [ExpHint]-inGroupExpHints (Op (Inner (SegOp (SegMap SegThreadScalar{} space ts _)))) = return $ do-  t <- ts-  case t of-    Prim pt ->-      return $ Hint (IxFun.iota $ map (primExpFromSubExp int32) $-                     segSpaceDims space ++ arrayDims t) $ Space $ scalarMemory pt-    _ ->-      return NoHint+inGroupExpHints :: Exp ExplicitMemory -> AllocM Kernels ExplicitMemory [ExpHint]+inGroupExpHints (Op (Inner (SegOp (SegMap _ space ts body))))+  | any private $ kernelBodyResult body = return $ do+      (t, r) <- zip ts $ kernelBodyResult body+      return $+        if private r+        then let dims = map (primExpFromSubExp int32) $+                            segSpaceDims space ++ arrayDims t+             in Hint (IxFun.iota dims) $ ScalarSpace (arrayDims t) $ elemType t+        else NoHint+  where private (Returns ResultPrivate _) = True+        private _                         = False inGroupExpHints e = return $ replicate (expExtTypeSize e) NoHint  inThreadExpHints :: Allocator ExplicitMemory m => Exp ExplicitMemory -> m [ExpHint]
src/Futhark/Pass/ExtractKernels.hs view
@@ -189,7 +189,7 @@ extractKernels =   Pass { passName = "extract kernels"        , passDescription = "Perform kernel extraction"-       , passFunction = fmap Prog . mapM transformFunDef . progFunctions+       , passFunction = fmap Prog . mapM transformFunDef . progFuns        }  -- In order to generate more stable threshold names, we keep track of@@ -434,7 +434,7 @@    where     paralleliseOuter path'-      | any (not . primType) $ lambdaReturnType red_fun = do+      | not $ all primType $ lambdaReturnType red_fun = do           -- Split into a chunked map and a reduction, with the latter           -- further transformed.           let fold_fun' = soacsLambdaToKernels fold_fun
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -305,7 +305,7 @@ maybeDistributeStm stm@(Let pat _ (If cond tbranch fbranch ret)) acc   | null (patternContextElements pat),     bodyContainsParallelism tbranch || bodyContainsParallelism fbranch ||-    any (not . primType) (ifReturns ret) =+    not (all primType (ifReturns ret)) =     distributeSingleStm acc stm >>= \case       Just (kernels, res, nest, acc')         | not $@@ -466,6 +466,21 @@     let rots' = map (const $ intConst Int32 0) (kernelNestWidths nest) ++ rots     return $ oneStm $ Let outerpat aux $ BasicOp $ Rotate rots' arr +maybeDistributeStm stm@(Let pat aux (BasicOp (Update arr slice (Var v)))) acc+  | not $ null $ sliceDims slice =+    distributeSingleStm acc stm >>= \case+    Just (kernels, res, nest, acc')+      | res == map Var (patternNames $ stmPattern stm),+        Just (perm, pat_unused) <- permutationAndMissing pat res -> do+          addKernels kernels+          localScope (typeEnvFromDistAcc acc') $ do+            nest' <- expandKernelNest pat_unused nest+            addKernel =<<+              segmentedUpdateKernel nest' perm (stmAuxCerts aux) arr slice v+            return acc'++    _ -> addStmToKernel stm acc+ -- XXX?  This rule is present to avoid the case where an in-place -- update is distributed as its own kernel, as this would mean thread -- then writes the entire array that it updated.  This is problematic@@ -663,6 +678,50 @@           [ (map Var (init gtids)++[i], v) | (i,v) <- is_vs ]           where (gtids,ws) = unzip ispace +segmentedUpdateKernel :: MonadFreshNames m =>+                         KernelNest+                      -> [Int]+                      -> Certificates+                      -> VName+                      -> Slice SubExp+                      -> VName+                      -> DistNestT m KernelsStms+segmentedUpdateKernel nest perm cs arr slice v = do+  (base_ispace, kernel_inps) <- flatKernel nest+  let slice_dims = sliceDims slice+  slice_gtids <- replicateM (length slice_dims) (newVName "gtid_slice")++  let ispace = base_ispace ++ zip slice_gtids slice_dims++  ((res_t, res), kstms) <- runBinder $ do++    -- Compute indexes into full array.+    v' <- certifying cs $+          letSubExp "v" $ BasicOp $ Index v $ map (DimFix . Var) slice_gtids+    let pexp = primExpFromSubExp int32+    slice_is <- traverse (letSubExp "index" <=< toExp) $+                fixSlice (map (fmap pexp) slice) $ map (pexp . Var) slice_gtids++    let write_is = map (Var . fst) base_ispace ++ slice_is+        arr' = maybe (error "incorrectly typed Update") kernelInputArray $+               find ((==arr) . kernelInputName) kernel_inps+    arr_t <- lookupType arr'+    v_t <- subExpType v'+    return (v_t,+            WriteReturns (arrayDims arr_t) arr' [(write_is, v')])++  mk_lvl <- mkSegLevel+  (k, prestms) <- mapKernel mk_lvl ispace kernel_inps [res_t] $+                  KernelBody () kstms [res]++  traverse renameStm <=< runBinder_ $ do+    addStms prestms++    let pat = Pattern [] $ rearrangeShape perm $+              patternValueElements $ loopNestingPattern $ fst nest++    letBind_ pat $ Op $ SegOp k+ segmentedHistKernel :: MonadFreshNames m =>                             KernelNest                          -> [Int]@@ -806,7 +865,7 @@    (ispace, kernel_inps) <- flatKernel nest -  unless (not $ free_in_op `namesIntersect` bound_by_nest) $+  when (free_in_op `namesIntersect` bound_by_nest) $     fail "Non-fold lambda uses nest-bound parameters."    let indices = map fst ispace
src/Futhark/Pass/ExtractKernels/Distribution.hs view
@@ -317,7 +317,7 @@         removeIdentityMappingGeneral bound_by_stms inner_pat inner_res   in (DistributionBody       { distributionTarget = Targets (inner_pat', inner_res') targets-      , distributionFreeInBody = fold (fmap freeIn stms) `namesSubtract` bound_by_stms+      , distributionFreeInBody = foldMap freeIn stms `namesSubtract` bound_by_stms       , distributionIdentityMap = inner_identity_map       , distributionExpandTarget = inner_expand_target       },
src/Futhark/Pass/ExtractKernels/ISRWIM.hs view
@@ -82,7 +82,7 @@             letSubExp "acc" $ BasicOp $ Index v $               fullSlice v_t [DimFix $ intConst Int32 0]           indexAcc Constant{} =-            fail "irwim: array accumulator is a constant."+            error "irwim: array accumulator is a constant."       accs' <- mapM indexAcc accs        let (_red_acc_params, red_elem_params) =
src/Futhark/Pass/KernelBabysitting.hs view
@@ -170,7 +170,7 @@         mapper ctx = identityMapper { mapOnBody = const (onBody ctx)                                     , mapOnOp = onOp ctx } -        mkSizeSubsts = fold . fmap mkStmSizeSubst+        mkSizeSubsts = foldMap mkStmSizeSubst           where mkStmSizeSubst (Let (Pattern [] [pe]) _ (Op (SizeOp (SplitSpace _ _ _ elems_per_i)))) =                   M.singleton (patElemName pe) elems_per_i                 mkStmSizeSubst _ = mempty
src/Futhark/Passes.hs view
@@ -35,6 +35,7 @@ standardPipeline =   passes [ simplifySOACS          , inlineAndRemoveDeadFunctions+         , simplifySOACS          , performCSE True          , simplifySOACS            -- We run fusion twice
src/Futhark/Representation/AST/Attributes.hs view
@@ -19,7 +19,6 @@   , builtInFunctions    -- * Extra tools-  , funDefByName   , asBasicOp   , safeExp   , subExpVars@@ -64,10 +63,6 @@ builtInFunctions :: M.Map Name (PrimType,[PrimType]) builtInFunctions = M.fromList $ map namify $ M.toList primFuns   where namify (k,(paramts,ret,_)) = (nameFromString k, (ret, paramts))---- | Find the function of the given name in the Futhark program.-funDefByName :: Name -> Prog lore -> Maybe (FunDef lore)-funDefByName fname = find ((fname ==) . funDefName) . progFunctions  -- | If the expression is a 'BasicOp', return that 'BasicOp', otherwise 'Nothing'. asBasicOp :: Exp lore -> Maybe (BasicOp lore)
src/Futhark/Representation/AST/Attributes/Names.hs view
@@ -138,7 +138,7 @@                      FreeAttr (ExpAttr lore)) =>                     Stms lore -> Result -> FV freeInStmsAndRes stms res =-  fvBind (boundByStms stms) $ fold (fmap freeIn' stms) <> freeIn' res+  fvBind (boundByStms stms) $ foldMap freeIn' stms <> freeIn' res  -- | A class indicating that we can obtain free variable information -- from values of this type.@@ -166,7 +166,7 @@   freeIn' (a,b,c) = freeIn' a <> freeIn' b <> freeIn' c  instance FreeIn a => FreeIn [a] where-  freeIn' = fold . fmap freeIn'+  freeIn' = foldMap freeIn'  instance (FreeAttr (ExpAttr lore),           FreeAttr (BodyAttr lore),@@ -214,7 +214,7 @@     freeIn' cs <> precomputed attr (freeIn' attr <> freeIn' e <> freeIn' pat)  instance FreeIn (Stm lore) => FreeIn (Stms lore) where-  freeIn' = fold . fmap freeIn'+  freeIn' = foldMap freeIn'  instance FreeIn Names where   freeIn' = fvNames@@ -235,6 +235,11 @@   freeIn' (Var v) = freeIn' v   freeIn' Constant{} = mempty +instance FreeIn Space where+  freeIn' (ScalarSpace d _) = freeIn' d+  freeIn' DefaultSpace = mempty+  freeIn' (Space _) = mempty+ instance FreeIn d => FreeIn (ShapeBase d) where   freeIn' = freeIn' . shapeDims @@ -244,7 +249,7 @@  instance FreeIn shape => FreeIn (TypeBase shape u) where   freeIn' (Array _ shape _) = freeIn' shape-  freeIn' (Mem _)           = mempty+  freeIn' (Mem s)           = freeIn' s   freeIn' (Prim _)          = mempty  instance FreeIn attr => FreeIn (Param attr) where@@ -307,7 +312,7 @@  -- | The names bound by the bindings. boundByStms :: Stms lore -> Names-boundByStms = fold . fmap boundByStm+boundByStms = foldMap boundByStm  -- | The names of the lambda parameters plus the index parameter. boundByLambda :: Lambda lore -> [VName]
src/Futhark/Representation/AST/Attributes/Scope.hs view
@@ -35,7 +35,6 @@ import Control.Monad.Reader import qualified Control.Monad.RWS.Strict import qualified Control.Monad.RWS.Lazy-import Data.Foldable import qualified Data.Map.Strict as M  import Futhark.Representation.AST.Annotations@@ -144,7 +143,7 @@   scopeOf = mconcat . map scopeOf  instance Scoped lore (Stms lore) where-  scopeOf = fold . fmap scopeOf+  scopeOf = foldMap scopeOf  instance Scoped lore (Stm lore) where   scopeOf = scopeOfPattern . stmPattern
src/Futhark/Representation/AST/Attributes/TypeOf.hs view
@@ -35,7 +35,6 @@        where  import Data.Maybe-import Data.Foldable import qualified Data.Set as S  import Futhark.Representation.AST.Syntax@@ -153,7 +152,7 @@   extendedScope (traverse subExpType res) bndscope   where bndscope = scopeOf stms         boundInLet (Let pat _ _) = S.fromList $ patternNames pat-        bound = S.toList $ fold $ fmap boundInLet stms+        bound = S.toList $ foldMap boundInLet stms  -- | Given the context and value merge parameters of a Futhark @loop@, -- produce the return type.
src/Futhark/Representation/AST/Pretty.hs view
@@ -77,28 +77,26 @@  instance Pretty Space where   ppr DefaultSpace = mempty-  ppr (Space s)    = text "@" <> text s+  ppr (Space s) = text "@" <> text s+  ppr (ScalarSpace d t) = text "@" <> brackets (mconcat $ map ppr d) <> ppr t  instance Pretty u => Pretty (TypeBase Shape u) where   ppr (Prim et) = ppr et   ppr (Array et (Shape ds) u) =     ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et-  ppr (Mem DefaultSpace) = text "mem"-  ppr (Mem (Space sp)) = text "mem" <> text "@" <> text sp+  ppr (Mem s) = text "mem" <> ppr s  instance Pretty u => Pretty (TypeBase ExtShape u) where   ppr (Prim et) = ppr et   ppr (Array et (Shape ds) u) =     ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et-  ppr (Mem DefaultSpace) = text "mem"-  ppr (Mem (Space sp)) = text "mem" <> text "@" <> text sp+  ppr (Mem s) = text "mem" <> ppr s  instance Pretty u => Pretty (TypeBase Rank u) where   ppr (Prim et) = ppr et   ppr (Array et (Rank n) u) =     ppr u <> mconcat (replicate n $ brackets mempty) <> ppr et-  ppr (Mem DefaultSpace) = text "mem"-  ppr (Mem (Space sp)) = text "mem" <> text "@" <> text sp+  ppr (Mem s) = text "mem" <> ppr s  instance Pretty Ident where   ppr ident = ppr (identType ident) <+> ppr (identName ident)@@ -268,7 +266,7 @@               | otherwise    = "fun"  instance PrettyLore lore => Pretty (Prog lore) where-  ppr = stack . punctuate line . map ppr . progFunctions+  ppr = stack . punctuate line . map ppr . progFuns  instance Pretty d => Pretty (DimChange d) where   ppr (DimCoercion se) = text "~" <> ppr se
src/Futhark/Representation/AST/Syntax.hs view
@@ -372,5 +372,5 @@                     deriving (Eq, Show, Ord)  -- | An entire Futhark program.-newtype Prog lore = Prog { progFunctions :: [FunDef lore] }+newtype Prog lore = Prog { progFuns :: [FunDef lore] }                     deriving (Eq, Ord, Show)
src/Futhark/Representation/AST/Syntax/Core.hs view
@@ -30,6 +30,7 @@          , Diet(..)          , ErrorMsg (..)          , ErrorMsgPart (..)+         , errorMsgArgTypes           -- * Values          , PrimValue(..)@@ -146,6 +147,10 @@ -- between host memory ('DefaultSpace') and GPU space. data Space = DefaultSpace            | Space SpaceId+           | ScalarSpace [SubExp] PrimType+             -- ^ A special kind of memory that is a statically sized+             -- array of some primitive type.  Used for private memory+             -- on GPUs.              deriving (Show, Eq, Ord)  -- | A string representing a specific non-default memory space.@@ -342,3 +347,10 @@ instance Traversable ErrorMsgPart where   traverse _ (ErrorString s) = pure $ ErrorString s   traverse f (ErrorInt32 a) = ErrorInt32 <$> f a++-- | How many non-constant parts does the error message have, and what+-- is their type?+errorMsgArgTypes :: ErrorMsg a -> [PrimType]+errorMsgArgTypes (ErrorMsg parts) = mapMaybe onPart parts+  where onPart ErrorString{} = Nothing+        onPart ErrorInt32{} = Just $ IntType Int32
src/Futhark/Representation/Aliases.hs view
@@ -41,7 +41,6 @@  import Control.Monad.Identity import Control.Monad.Reader-import Data.Foldable import Data.Maybe import qualified Data.Map.Strict as M @@ -295,7 +294,7 @@   -- bound in bnds.   let (aliases, consumed) = mkStmsAliases bnds res       boundNames =-        fold $ fmap (namesFromList . patternNames . stmPattern) bnds+        foldMap (namesFromList . patternNames . stmPattern) bnds       aliases' = map (`namesSubtract` boundNames) aliases       consumed' = consumed `namesSubtract` boundNames   in (map Names' aliases', Names' consumed')
src/Futhark/Representation/ExplicitMemory.hs view
@@ -76,13 +76,8 @@        , lookupMemInfo        , subExpMemInfo        , lookupArraySummary-       , fullyLinear-       , ixFunMatchesInnerShape        , existentialiseIxFun -       , scalarMemory-       , allScalarMemory-          -- * Module re-exports        , module Futhark.Representation.AST.Attributes        , module Futhark.Representation.AST.Traversals@@ -98,8 +93,9 @@ import Control.Monad.Reader import Control.Monad.Except import qualified Data.Map.Strict as M-import Data.Foldable (traverse_)+import Data.Foldable (traverse_, toList) import Data.List+import qualified Data.Set as S  import Futhark.Analysis.Metrics import Futhark.Representation.AST.Syntax@@ -115,7 +111,6 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.Analysis.PrimExp.Simplify import Futhark.Util-import Futhark.Util.IntegralExp import qualified Futhark.Util.Pretty as PP import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Lore@@ -195,7 +190,7 @@  instance PP.Pretty inner => PP.Pretty (MemOp inner) where   ppr (Alloc e DefaultSpace) = PP.text "alloc" <> PP.apply [PP.ppr e]-  ppr (Alloc e (Space sp)) = PP.text "alloc" <> PP.apply [PP.ppr e, PP.text sp]+  ppr (Alloc e s) = PP.text "alloc" <> PP.apply [PP.ppr e, PP.ppr s]   ppr (Inner k) = PP.ppr k  instance OpMetrics inner => OpMetrics (MemOp inner) where@@ -280,7 +275,7 @@  instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d u ret) where   freeIn' (MemArray _ shape _ ret) = freeIn' shape <> freeIn' ret-  freeIn' MemMem{} = mempty+  freeIn' (MemMem s) = freeIn' s   freeIn' MemPrim{} = mempty  instance (Substitute d, Substitute ret) => Substitute (MemInfo d u ret) where@@ -321,10 +316,8 @@ instance (PP.Pretty (TypeBase (ShapeBase d) u),           PP.Pretty d, PP.Pretty u, PP.Pretty ret) => PP.Pretty (MemInfo d u ret) where   ppr (MemPrim bt) = PP.ppr bt-  ppr (MemMem DefaultSpace) =-    PP.text "mem"-  ppr (MemMem (Space sp)) =-    PP.text "mem" <> PP.text "@" <> PP.text sp+  ppr (MemMem DefaultSpace) = PP.text "mem"+  ppr (MemMem s) = PP.text "mem" <> PP.ppr s   ppr (MemArray bt shape u ret) =     PP.ppr (Array bt shape u) <> PP.text "@" <> PP.ppr ret @@ -418,9 +411,7 @@   ppr (ReturnsInBlock v ixfun) =     PP.parens $ PP.text (pretty v) <> PP.text "->" <> PP.ppr ixfun   ppr (ReturnsNewBlock space i ixfun) =-    PP.text ("?" ++ show i) <> space' <> PP.text "->" <> PP.ppr ixfun-    where space' = case space of DefaultSpace -> mempty-                                 Space s -> PP.text $ "@" ++ s+    PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" <> PP.ppr ixfun  instance FreeIn MemReturn where   freeIn' (ReturnsInBlock v ixfun) = freeIn' v <> freeIn' ixfun@@ -562,25 +553,8 @@   let (ctx_ts, val_ts) = splitFromEnd (length rettype) ts       (ctx_res, _val_res) = splitFromEnd (length rettype) res -      getId :: (SubExp,Int) -> Maybe (VName,Int)-      getId (Var ii, i) = Just (ii,i)-      getId (Constant _, _) = Nothing--      (ctx_map_ids, ctx_map_exts) =-        getExtMaps $ mapMaybe getId $ zip ctx_res [0..length ctx_res - 1]-       existentialiseIxFun0 :: IxFun -> ExtIxFun-      existentialiseIxFun0 = IxFun.substituteInIxFun ctx_map_ids . fmap (fmap Free)--      getCt :: (Int,SubExp) -> Maybe (Ext VName, PrimExp (Ext VName))-      getCt (_, Var _) = Nothing-      getCt (i, Constant c) = Just (Ext i, ValueExp c)--      ctx_map_cts = M.fromList $ mapMaybe getCt $-                    zip [0..length ctx_res - 1] ctx_res--      substConstsInExtIndFun :: ExtIxFun -> ExtIxFun-      substConstsInExtIndFun = IxFun.substituteInIxFun (ctx_map_cts<>ctx_map_exts)+      existentialiseIxFun0 = fmap $ fmap Free        fetchCtx i = case maybeNth i $ zip ctx_res ctx_ts of                      Nothing -> throwError $ "Cannot find context variable " ++@@ -609,24 +583,25 @@           throwError $ unwords ["Expected ext dim", pretty i, "=>", pretty x,                                 "but got", pretty y] +      extsInMemInfo :: MemInfo ExtSize u MemReturn -> S.Set Int+      extsInMemInfo (MemArray _ shp _ ret) =+        extInShape shp <> extInMemReturn ret+      extsInMemInfo _ = S.empty+       checkMemReturn (ReturnsInBlock x_mem x_ixfun) (ArrayIn y_mem y_ixfun)-          | x_mem == y_mem = do-              let x_ixfun' = substConstsInExtIndFun x_ixfun-                  y_ixfun' = existentialiseIxFun0   y_ixfun-              unless (x_ixfun' == y_ixfun') $+          | x_mem == y_mem =+              unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $                 throwError $ unwords  ["Index function unification failed (ReturnsInBlock)",-                    "\nixfun of body result: ", pretty y_ixfun',-                    "\nixfun of return type: ", pretty x_ixfun',+                    "\nixfun of body result: ", pretty y_ixfun,+                    "\nixfun of return type: ", pretty x_ixfun,                     "\nand context elements: ", pretty ctx_res]       checkMemReturn (ReturnsNewBlock x_space x_ext x_ixfun)                      (ArrayIn y_mem y_ixfun) = do         (x_mem, x_mem_type)  <- fetchCtx x_ext-        let x_ixfun' = substConstsInExtIndFun x_ixfun-            y_ixfun' = existentialiseIxFun0   y_ixfun-        unless (x_ixfun' == y_ixfun') $+        unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $           throwError $ unwords  ["Index function unification failed (ReturnsNewBlock)",-            "\nixfun of body result: ", pretty y_ixfun',-            "\nixfun of return type: ", pretty x_ixfun',+            "\nixfun of body result: ", pretty y_ixfun,+            "\nixfun of return type: ", pretty x_ixfun,             "\nand context elements: ", pretty ctx_res]         case x_mem_type of           MemMem y_space -> do@@ -652,6 +627,13 @@                       , s                       ] +  unless (length (S.unions $ map extsInMemInfo rettype)  == length ctx_res) $+    TC.bad $ TC.TypeError $ "Too many context parameters for the number of " +++    "existentials in the return type! type:\n  " +++    prettyTuple rettype +++    "\ncannot match context parameters:\n  " ++ prettyTuple ctx_res++   either bad return =<< runExceptT (zipWithM_ checkReturn rettype val_ts)  matchPatternToExp :: (ExplicitMemorish lore) =>@@ -668,8 +650,11 @@       (ctx_map_ids, ctx_map_exts) =         getExtMaps $ zip ctx_ids [0..length ctx_ids - 1] +  let rt_exts = foldMap extInExpReturns rt+   unless (length val_ts == length rt &&-          and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt)) $+          and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt) &&+          M.keysSet ctx_map_exts `S.isSubsetOf` S.map Ext rt_exts) $     TC.bad $ TC.TypeError $ "Expression type:\n  " ++ prettyTuple rt ++                             "\ncannot match pattern type:\n  " ++ prettyTuple val_ts ++                             "\nwith context elements: " ++ pretty ctx_ids@@ -692,11 +677,33 @@              Just (ReturnsNewBlock y_space y_i y_ixfun)) ->               let x_ixfun' = IxFun.substituteInIxFun  ctxids x_ixfun                   y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun-              in  x_space == y_space && x_i == y_i && x_ixfun' == y_ixfun'+              in  x_space == y_space && x_i == y_i && IxFun.closeEnough x_ixfun' y_ixfun'             (_, Nothing) -> True             _ -> False         matches _ _ _ _ = False +        extInExpReturns :: ExpReturns -> S.Set Int+        extInExpReturns (MemArray _ shape _ mem_return) =+          extInShape shape <> maybe S.empty extInMemReturn mem_return+        extInExpReturns _ = mempty+++extInShape :: ShapeBase (Ext SubExp) -> S.Set Int+extInShape shape = S.fromList $ mapMaybe isExt $ shapeDims shape++extInMemReturn :: MemReturn -> S.Set Int+extInMemReturn (ReturnsInBlock _ extixfn) = extInIxFn extixfn+extInMemReturn (ReturnsNewBlock _ i extixfn) =+  S.singleton i <> extInIxFn extixfn++extInIxFn :: ExtIxFun -> S.Set Int+extInIxFn ixfun = S.fromList $ concatMap (mapMaybe isExt . toList) ixfun++isExt :: Ext a -> Maybe Int+isExt (Ext i) = Just i+isExt _ = Nothing++ varMemInfo :: ExplicitMemorish lore =>               VName -> TC.TypeM lore (MemInfo SubExp NoUniqueness MemBind) varMemInfo name = do@@ -739,6 +746,7 @@                  VName -> MemInfo SubExp u MemBind              -> TC.TypeM lore () checkMemInfo _ (MemPrim _) = return ()+checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require [Prim int32]) d checkMemInfo _ (MemMem _) = return () checkMemInfo name (MemArray _ shape _ (ArrayIn v ixfun)) = do   t <- lookupType v@@ -1022,24 +1030,3 @@           where mem' = case M.lookup mem parammap of                   Just (Var v, _) -> v                   _               -> mem---- | Is an array of the given shape stored fully flat row-major with--- the given index function?-fullyLinear :: (Eq num, IntegralExp num) =>-               ShapeBase num -> IxFun.IxFun num -> Bool-fullyLinear shape ixfun =-  IxFun.isLinear ixfun && ixFunMatchesInnerShape shape ixfun--ixFunMatchesInnerShape :: (Eq num, IntegralExp num) =>-                          ShapeBase num -> IxFun.IxFun num -> Bool-ixFunMatchesInnerShape shape ixfun =-  drop 1 (IxFun.shape ixfun) == drop 1 (shapeDims shape)---- | Construct the scalar memory space corresponding to a given primitive type.-scalarMemory :: PrimType -> SpaceId-scalarMemory = ("scalar_"++) . pretty---- | A mapping from all scalar memory spaces to the 'PrimType' they--- store.-allScalarMemory :: M.Map SpaceId PrimType-allScalarMemory = M.fromList $ zip (map scalarMemory allPrimTypes) allPrimTypes
src/Futhark/Representation/ExplicitMemory/IndexFunction.hs view
@@ -21,6 +21,8 @@        , isDirect        , isLinear        , substituteInIxFun+       , leastGeneralGeneralization+       , closeEnough        )        where @@ -34,6 +36,8 @@ import Control.Monad.Writer import qualified Data.Map.Strict as M +import Futhark.Analysis.PrimExp (PrimExp(..))+import Futhark.Representation.AST.Syntax.Core (Ext(..)) import Futhark.Transform.Substitute import Futhark.Transform.Rename import Futhark.Representation.AST.Syntax@@ -41,15 +45,14 @@ import Futhark.Representation.AST.Attributes import Futhark.Util.IntegralExp import Futhark.Util.Pretty-import Futhark.Analysis.PrimExp.Convert-+import Futhark.Analysis.PrimExp.Convert (substituteInPrimExp)+import qualified Futhark.Analysis.PrimExp.Generalize as PEG --- | LMAD's representation consists of a permutation, a general offset, and, for--- each dimension a stride, rotate factor, number of elements, permutation, and--- monotonicity and unit-stride info for each dimension.  Note that the--- permutation is not strictly necessary in that the permutation can be--- performed directly on LMAD dimensions, but then it is difficult to extract--- the permutation back from an LMAD.+-- | LMAD's representation consists of a general offset and for each dimension a+-- stride, rotate factor, number of elements (or shape), permutation, and+-- monotonicity. Note that the permutation is not strictly necessary in that the+-- permutation can be performed directly on LMAD dimensions, but then it is+-- difficult to extract the permutation back from an LMAD. -- -- LMAD algebra is closed under composition w.r.t. operators such as permute, -- repeat, index and slice.  However, other operations, such as reshape, cannot@@ -62,9 +65,10 @@ -- However, we expect that the common case is when the index function is one -- LMAD -- we call this the 'nice' representation. ----- Finally, the list of LMADs is tupled with the shape of the original array,--- and with contiguous info, i.e., if we instantiate all the points of the--- current index function, do we get a contiguous memory interval?+-- Finally, the list of LMADs is kept in an @IxFun@ together with the shape of+-- the original array, and a bit to indicate whether the index function is+-- contiguous, i.e., if we instantiate all the points of the current index+-- function, do we get a contiguous memory interval? -- -- By definition, the LMAD denotes the set of points (simplified): --@@ -785,3 +789,68 @@                     Monotonicity -> LMADDim num -> Bool         isMonDim mon (LMADDim s r _ _ ldmon) =           s == 0 || ((ignore_rots || r == 0) && mon == ldmon)++-- | Generalization (anti-unification)+--+-- Anti-unification of two index functions is supported under the following conditions:+--   0. Both index functions are represented by ONE lmad (assumed common case!)+--   1. The support array of the two indexfuns have the same dimensionality+--      (we can relax this condition if we use a 1D support, as we probably should!)+--   2. The contiguous property and the per-dimension monotonicity are the same+--      (otherwise we might loose important information; this can be relaxed!)+--   3. Most importantly, both index functions correspond to the same permutation+--      (since the permutation is represented by INTs, this restriction cannot+--       be relaxed, unless we move to a gated-LMAD representation!)+--+-- `k0` is the existential to use for the shape of the array.+leastGeneralGeneralization :: Eq v => IxFun (PrimExp v) -> IxFun (PrimExp v) ->+                              Maybe (IxFun (PrimExp (Ext v)), [(PrimExp v, PrimExp v)])+leastGeneralGeneralization (IxFun (lmad1 :| []) oshp1 ctg1) (IxFun (lmad2 :| []) oshp2 ctg2) = do+  guard $+    length oshp1 == length oshp2 &&+    ctg1 == ctg2 &&+    map ldPerm (lmadDims lmad1) == map ldPerm (lmadDims lmad2) &&+    lmadDMon lmad1 == lmadDMon lmad2+  let (ctg, dperm, dmon) = (ctg1, lmadPermutation lmad1, lmadDMon lmad1)+  (dshp, m1) <- generalize [] (lmadDShp lmad1) (lmadDShp lmad2)+  (oshp, m2) <- generalize m1 oshp1 oshp2+  (dstd, m3) <- generalize m2 (lmadDSrd lmad1) (lmadDSrd lmad2)+  (drot, m4) <- generalize m3 (lmadDRot lmad1) (lmadDRot lmad2)+  (offt, m5) <- PEG.leastGeneralGeneralization m4 (lmadOffset lmad1) (lmadOffset lmad2)+  let lmad_dims = map (\(a,b,c,d,e) -> LMADDim a b c d e) $+        zip5 dstd drot dshp dperm dmon+      lmad = LMAD offt lmad_dims+  return (IxFun (lmad :| []) oshp ctg, m5)+  where lmadDMon = map ldMon    . lmadDims+        lmadDSrd = map ldStride . lmadDims+        lmadDShp = map ldShape  . lmadDims+        lmadDRot = map ldRotate . lmadDims+        generalize m l1 l2 =+          foldM (\(l_acc, m') (pe1,pe2) -> do+                    (e, m'') <- PEG.leastGeneralGeneralization m' pe1 pe2+                    return (l_acc++[e], m'')+                ) ([], m) (zip l1 l2)+leastGeneralGeneralization _ _ = Nothing++-- | When comparing index functions as part of the type check in ExplicitMemory,+-- we may run into problems caused by the simplifier. As index functions can be+-- generalized over if-then-else expressions, the simplifier might hoist some of+-- the code from inside the if-then-else (computing the offset of an array, for+-- instance), but now the type checker cannot verify that the generalized index+-- function is valid, because some of the existentials are computed somewhere+-- else. To Work around this, we've had to relax the ExplicitMemory type-checker+-- a bit, specifically, we've introduced this function to verify whether two+-- index functions are "close enough" that we can assume that they match. We use+-- this instead of `ixfun1 == ixfun2` and hope that it's good enough.+closeEnough :: IxFun num -> IxFun num -> Bool+closeEnough ixf1 ixf2 =+  (length (base ixf1) == length (base ixf2)) &&+  (ixfunContig ixf1 == ixfunContig ixf2) &&+  (NE.length (ixfunLMADs ixf1) == NE.length (ixfunLMADs ixf2)) &&+  all closeEnoughLMADs (NE.zip (ixfunLMADs ixf1) (ixfunLMADs ixf2))+  where+    closeEnoughLMADs :: (LMAD num, LMAD num) -> Bool+    closeEnoughLMADs (lmad1, lmad2) =+      length (lmadDims lmad1) == length (lmadDims lmad2) &&+      map ldPerm (lmadDims lmad1) ==+      map ldPerm (lmadDims lmad2)
src/Futhark/Representation/Kernels/Kernel.hs view
@@ -56,7 +56,6 @@ import Control.Monad.Writer hiding (mapM_) import Control.Monad.Identity hiding (mapM_) import qualified Data.Map.Strict as M-import Data.Foldable import Data.List  import Futhark.Representation.AST@@ -157,9 +156,16 @@ -- might otherwise be removed by the simplifier because they're -- semantically redundant.  This has no semantic effect and can be -- ignored at code generation.-data ResultManifest = ResultNoSimplify -- ^ Don't simplify this one!-                    | ResultMaySimplify -- ^ Go nuts.-                  deriving (Eq, Show, Ord)+data ResultManifest+  = ResultNoSimplify+    -- ^ Don't simplify this one!+  | ResultMaySimplify+    -- ^ Go nuts.+  | ResultPrivate+    -- ^ The results produced are only used within the+    -- same physical thread later on, and can thus be+    -- kept in registers.+  deriving (Eq, Show, Ord)  data KernelResult = Returns ResultManifest SubExp                     -- ^ Each "worker" in the kernel returns this.@@ -199,7 +205,7 @@ instance Attributes lore => FreeIn (KernelBody lore) where   freeIn' (KernelBody attr stms res) =     fvBind bound_in_stms $ freeIn' attr <> freeIn' stms <> freeIn' res-    where bound_in_stms = fold $ fmap boundByStm stms+    where bound_in_stms = foldMap boundByStm stms  instance Attributes lore => Substitute (KernelBody lore) where   substituteNames subst (KernelBody attr stms res) =@@ -322,6 +328,8 @@ instance Pretty KernelResult where   ppr (Returns ResultNoSimplify what) =     text "returns (manifest)" <+> ppr what+  ppr (Returns ResultPrivate what) =+    text "returns (private)" <+> ppr what   ppr (Returns ResultMaySimplify what) =     text "returns" <+> ppr what   ppr (WriteReturns rws arr res) =@@ -358,14 +366,6 @@               | SegGroup { segNumGroups :: Count NumGroups SubExp                          , segGroupSize :: Count GroupSize SubExp                          , segVirt :: SegVirt }-              | SegThreadScalar { segNumGroups :: Count NumGroups SubExp-                                , segGroupSize :: Count GroupSize SubExp-                                , segVirt :: SegVirt }-                -- ^ Like 'SegThread', but with the invariant that the-                -- results produced are only used within the same-                -- physical thread later on, and can thus be kept in-                -- registers.  May only occur within an enclosing-                -- 'SegGroup' construct.               deriving (Eq, Ord, Show)  -- | Index space of a 'SegOp'.@@ -461,8 +461,6 @@     namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody  checkSegLevel :: Maybe SegLevel -> SegLevel -> TC.TypeM lore ()-checkSegLevel Nothing SegThreadScalar{} =-  TC.bad $ TC.TypeError "SegThreadScalar at top level." checkSegLevel Nothing _ =   return () checkSegLevel (Just SegThread{}) _ =@@ -646,11 +644,6 @@   <$> traverse (mapOnSegOpSubExp tv) num_groups   <*> traverse (mapOnSegOpSubExp tv) group_size   <*> pure virt-mapOnSegLevel tv (SegThreadScalar num_groups group_size virt) =-  SegThreadScalar-  <$> traverse (mapOnSegOpSubExp tv) num_groups-  <*> traverse (mapOnSegOpSubExp tv) group_size-  <*> pure virt  mapOnSegOpType :: Monad m =>                   SegOpMapper flore tlore m -> Type -> m Type@@ -734,7 +727,6 @@  instance PP.Pretty SegLevel where   ppr SegThread{} = "thread"-  ppr SegThreadScalar{} = "scalar"   ppr SegGroup{} = "group"  ppSegLevel :: SegLevel -> PP.Doc
src/Futhark/Representation/Kernels/Simplify.hs view
@@ -196,9 +196,6 @@   simplify (SegGroup num_groups group_size virt) =     SegGroup <$> traverse Engine.simplify num_groups <*>     traverse Engine.simplify group_size <*> pure virt-  simplify (SegThreadScalar num_groups group_size virt) =-    SegThreadScalar <$> traverse Engine.simplify num_groups <*>-    traverse Engine.simplify group_size <*> pure virt  instance Engine.Simplifiable SegSpace where   simplify (SegSpace phys dims) =@@ -227,9 +224,11 @@ kernelRules = standardRules <>               ruleBook [ RuleOp removeInvariantKernelResults                        , RuleOp mergeSegRedOps-                       , RuleOp redomapIotaToLoop ]+                       , RuleOp redomapIotaToLoop+                       ]                        [ RuleOp distributeKernelResults-                       , RuleBasicOp removeUnnecessaryCopy]+                       , RuleBasicOp removeUnnecessaryCopy+                       ]  -- If a kernel produces something invariant to the kernel, turn it -- into a replicate.@@ -237,10 +236,6 @@ removeInvariantKernelResults vtable (Pattern [] kpes) attr                              (SegOp (SegMap lvl space ts (KernelBody _ kstms kres))) = Simplify $ do -  case lvl of-    SegThreadScalar{} -> cannotSimplify-    _ -> return ()-   (ts', kpes', kres') <-     unzip3 <$> filterM checkForInvarianceResult (zip3 ts kpes kres) @@ -253,8 +248,9 @@   where isInvariant Constant{} = True         isInvariant (Var v) = isJust $ ST.lookup v vtable -        checkForInvarianceResult (_, pe, Returns _ se)-          | isInvariant se = do+        checkForInvarianceResult (_, pe, Returns rm se)+          | rm == ResultMaySimplify,+            isInvariant se = do               letBindNames_ [patElemName pe] $                 BasicOp $ Replicate (Shape $ segSpaceDims space) se               return False@@ -270,24 +266,32 @@   -- Iterate through the bindings.  For each, we check whether it is   -- in kres and can be moved outside.  If so, we remove it from kres   -- and kpes and make it a binding outside.-  (kpes', kts', kres', kstms_rev) <- localScope (scopeOfSegSpace space) $-    foldM distribute (kpes, kts, kres, []) kstms+  (kpes', kts', kres', kstms') <- localScope (scopeOfSegSpace space) $+    foldM distribute (kpes, kts, kres, mempty) kstms    when (kpes' == kpes)     cannotSimplify    addStm $ Let (Pattern [] kpes') attr $ Op $ SegOp $-    SegMap lvl space kts' $ mkWiseKernelBody () (stmsFromList $ reverse kstms_rev) kres'+    SegMap lvl space kts' $ mkWiseKernelBody () kstms' kres'   where-    free_in_kstms = fold $ fmap freeIn kstms+    free_in_kstms = foldMap freeIn kstms -    distribute (kpes', kts', kres', kstms_rev) bnd-      | Let (Pattern [] [pe]) _ (BasicOp (Index arr slice)) <- bnd,+    sliceWithGtidsFixed stm+      | Let _ _ (BasicOp (Index arr slice)) <- stm,         space_slice <- map (DimFix . Var . fst) $ unSegSpace space,         space_slice `isPrefixOf` slice,         remaining_slice <- drop (length space_slice) slice,         all (isJust . flip ST.lookup vtable) $ namesToList $-          freeIn arr <> freeIn remaining_slice,+          freeIn arr <> freeIn remaining_slice =+          Just (remaining_slice, arr)++      | otherwise =+          Nothing++    distribute (kpes', kts', kres', kstms') stm+      | Let (Pattern [] [pe]) _ _ <- stm,+        Just (remaining_slice, arr) <- sliceWithGtidsFixed stm,         Just (kpe, kpes'', kts'', kres'') <- isResult kpes' kts' kres' pe = do           let outer_slice = map (\d -> DimSlice                                        (constant (0::Int32))@@ -303,11 +307,11 @@             else index kpe           return (kpes'', kts'', kres'',                   if patElemName pe `nameIn` free_in_kstms-                  then bnd : kstms_rev-                  else kstms_rev)+                  then kstms' <> oneStm stm+                  else kstms') -    distribute (kpes', kts', kres', kstms_rev) bnd =-      return (kpes', kts', kres', bnd : kstms_rev)+    distribute (kpes', kts', kres', kstms') stm =+      return (kpes', kts', kres', kstms' <> oneStm stm)      isResult kpes' kts' kres' pe =       case partition matches $ zip3 kpes' kts' kres' of
src/Futhark/Representation/Primitive.hs view
@@ -833,12 +833,20 @@   , f32 "log10_32" (logBase 10), f64 "log10_64" (logBase 10)   , f32 "log2_32" (logBase 2), f64 "log2_64" (logBase 2)   , f32 "exp32" exp, f64 "exp64" exp+   , f32 "sin32" sin, f64 "sin64" sin+  , f32 "sinh32" sinh, f64 "sinh64" sinh   , f32 "cos32" cos, f64 "cos64" cos+  , f32 "cosh32" cosh, f64 "cosh64" cosh   , f32 "tan32" tan, f64 "tan64" tan+  , f32 "tanh32" tanh, f64 "tanh64" tanh   , f32 "asin32" asin, f64 "asin64" asin+  , f32 "asinh32" asinh, f64 "asinh64" asinh   , f32 "acos32" acos, f64 "acos64" acos+  , f32 "acosh32" acosh, f64 "acosh64" acosh   , f32 "atan32" atan, f64 "atan64" atan+  , f32 "atanh32" atanh, f64 "atanh64" atanh+   , f32 "round32" roundFloat, f64 "round64" roundDouble   , f32 "ceil32" ceilFloat, f64 "ceil64" ceilDouble   , f32 "floor32" floorFloat, f64 "floor64" floorDouble@@ -855,6 +863,56 @@   , i32 "popc32" $ IntValue . Int32Value . fromIntegral . popCount   , i64 "popc64" $ IntValue . Int32Value . fromIntegral . popCount +  , ("mad_hi8", ([IntType Int8, IntType Int8, IntType Int8], IntType Int8,+                 \case+                   [IntValue (Int8Value a), IntValue (Int8Value b), IntValue (Int8Value c)] ->+                     Just $ IntValue . Int8Value $ mad_hi8 (Int8Value a) (Int8Value b) c+                   _ -> Nothing+                ))+  , ("mad_hi16", ([IntType Int16, IntType Int16, IntType Int16], IntType Int16,+                 \case+                   [IntValue (Int16Value a), IntValue (Int16Value b), IntValue (Int16Value c)] ->+                     Just $ IntValue . Int16Value  $ mad_hi16 (Int16Value a) (Int16Value b) c+                   _ -> Nothing+                ))+  , ("mad_hi32", ([IntType Int32, IntType Int32, IntType Int32], IntType Int32,+                  \case+                   [IntValue (Int32Value a), IntValue (Int32Value b), IntValue (Int32Value c)] ->+                     Just $ IntValue . Int32Value  $ mad_hi32 (Int32Value a) (Int32Value b) c+                   _ -> Nothing+                ))+  , ("mad_hi64", ([IntType Int64, IntType Int64, IntType Int64], IntType Int64,+                  \case+                    [IntValue (Int64Value a), IntValue (Int64Value b), IntValue (Int64Value c)] ->+                      Just $ IntValue . Int64Value $ mad_hi64 (Int64Value a) (Int64Value b) c+                    _ -> Nothing+                ))++  , ("mul_hi8", ([IntType Int8, IntType Int8], IntType Int8,+                 \case+                   [IntValue (Int8Value a), IntValue (Int8Value b)] ->+                     Just $ IntValue . Int8Value $ mul_hi8 (Int8Value a) (Int8Value b)+                   _ -> Nothing+                ))+  , ("mul_hi16", ([IntType Int16, IntType Int16], IntType Int16,+                 \case+                   [IntValue (Int16Value a), IntValue (Int16Value b)] ->+                     Just $ IntValue . Int16Value  $ mul_hi16 (Int16Value a) (Int16Value b)+                   _ -> Nothing+                ))+  , ("mul_hi32", ([IntType Int32, IntType Int32], IntType Int32,+                  \case+                   [IntValue (Int32Value a), IntValue (Int32Value b)] ->+                     Just $ IntValue . Int32Value  $ mul_hi32 (Int32Value a) (Int32Value b)+                   _ -> Nothing+                ))+  , ("mul_hi64", ([IntType Int64, IntType Int64], IntType Int64,+                  \case+                    [IntValue (Int64Value a), IntValue (Int64Value b)] ->+                      Just $ IntValue . Int64Value $ mul_hi64 (Int64Value a) (Int64Value b)+                    _ -> Nothing+                ))+   , ("atan2_32",      ([FloatType Float32, FloatType Float32], FloatType Float32,       \case@@ -916,24 +974,15 @@           Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x         _ -> Nothing)) -  , ("lerp32",-     ([FloatType Float32, FloatType Float32, FloatType Float32], FloatType Float32,-      \case-        [FloatValue (Float32Value v0),-         FloatValue (Float32Value v1),-         FloatValue (Float32Value t)] ->-          Just $ FloatValue $ Float32Value $-          v0 + (v1-v0)*max 0 (min 1 t)-        _ -> Nothing))-  , ("lerp64",-     ([FloatType Float64, FloatType Float64, FloatType Float64], FloatType Float64,-      \case-        [FloatValue (Float64Value v0),-         FloatValue (Float64Value v1),-         FloatValue (Float64Value t)] ->-          Just $ FloatValue $ Float64Value $-          v0 + (v1-v0)*max 0 (min 1 t)-        _ -> Nothing))+  , f32_3 "lerp32" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t))+  , f64_3 "lerp64" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t))++  , f32_3 "mad32" (\a b c -> a*b+c)+  , f64_3 "mad64" (\a b c -> a*b+c)++  , f32_3 "fma32" (\a b c -> a*b+c)+  , f64_3 "fma64" (\a b c -> a*b+c)+   ]   where i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f))         i16 s f = (s, ([IntType Int16], IntType Int32, i16PrimFun f))@@ -941,6 +990,10 @@         i64 s f = (s, ([IntType Int64], IntType Int32, i64PrimFun f))         f32 s f = (s, ([FloatType Float32], FloatType Float32, f32PrimFun f))         f64 s f = (s, ([FloatType Float64], FloatType Float64, f64PrimFun f))+        f32_3 s f = (s, ([FloatType Float32,FloatType Float32,FloatType Float32],+                         FloatType Float32, f32PrimFun3 f))+        f64_3 s f = (s, ([FloatType Float64,FloatType Float64,FloatType Float64],+                         FloatType Float64, f64PrimFun3 f))          i8PrimFun f [IntValue (Int8Value x)] =           Just $ f x@@ -966,6 +1019,18 @@           Just $ FloatValue $ Float64Value $ f x         f64PrimFun _ _ = Nothing +        f32PrimFun3 f [FloatValue (Float32Value a),+                       FloatValue (Float32Value b),+                       FloatValue (Float32Value c)] =+          Just $ FloatValue $ Float32Value $ f a b c+        f32PrimFun3 _ _ = Nothing++        f64PrimFun3 f [FloatValue (Float64Value a),+                       FloatValue (Float64Value b),+                       FloatValue (Float64Value c)] =+          Just $ FloatValue $ Float64Value $ f a b c+        f64PrimFun3 _ _ = Nothing+ -- | Is the given value kind of zero? zeroIsh :: PrimValue -> Bool zeroIsh (IntValue k)                  = zeroIshInt k@@ -1134,3 +1199,39 @@ prettySigned :: Bool -> PrimType -> String prettySigned True (IntType it) = 'u' : drop 1 (pretty it) prettySigned _ t = pretty t++mul_hi8 :: IntValue -> IntValue -> Int8+mul_hi8 a b =+  let a' = intToWord64 a+      b' = intToWord64 b+  in fromIntegral (shiftR (a' * b') 8)++mul_hi16 :: IntValue -> IntValue -> Int16+mul_hi16 a b =+  let a' = intToWord64 a+      b' = intToWord64 b+  in fromIntegral (shiftR (a' * b') 16)++mul_hi32 :: IntValue -> IntValue -> Int32+mul_hi32 a b =+  let a' = intToWord64 a+      b' = intToWord64 b+  in fromIntegral (shiftR (a' * b') 32)++mul_hi64 :: IntValue -> IntValue -> Int64+mul_hi64 a b =+  let a' = (toInteger . intToWord64) a+      b' = (toInteger . intToWord64) b+  in fromIntegral (shiftR (a' * b') 64)++mad_hi8 :: IntValue -> IntValue -> Int8 -> Int8+mad_hi8 a b c = mul_hi8 a b + c++mad_hi16 :: IntValue -> IntValue -> Int16 -> Int16+mad_hi16 a b c = mul_hi16 a b + c++mad_hi32 :: IntValue -> IntValue -> Int32 -> Int32+mad_hi32 a b c = mul_hi32 a b + c++mad_hi64 :: IntValue -> IntValue -> Int64 -> Int64+mad_hi64 a b c = mul_hi64 a b + c
src/Futhark/Representation/Ranges.hs view
@@ -34,7 +34,6 @@  import Control.Monad.Identity import Control.Monad.Reader-import Data.Foldable  import Futhark.Representation.AST.Syntax import Futhark.Representation.AST.Attributes@@ -166,7 +165,7 @@ mkBodyRanges :: Stms lore -> Result -> [Range] mkBodyRanges bnds = map $ removeUnknownBounds . rangeOf   where boundInBnds =-          fold $ fmap (namesFromList . patternNames . stmPattern) bnds+          foldMap (namesFromList . patternNames . stmPattern) bnds         removeUnknownBounds (lower,upper) =           (removeUnknownBound lower,            removeUnknownBound upper)
src/Futhark/Test/Values.hs view
@@ -497,8 +497,7 @@  compareValue :: Int -> Value -> Value -> [Mismatch] compareValue i got_v expected_v-  | product (valueShape got_v) == 0 && product (valueShape expected_v) == 0-    || valueShape got_v == valueShape expected_v =+  | valueShape got_v == valueShape expected_v =     case (got_v, expected_v) of       (Int8Value _ got_vs, Int8Value _ expected_vs) ->         compareNum 1 got_vs expected_vs@@ -556,6 +555,7 @@ minTolerance :: Fractional a => a minTolerance = 0.002 -- 0.2% -tolerance :: (Ord a, Fractional a, UVec.Unbox a) => Vector a -> a-tolerance = UVec.foldl tolerance' minTolerance+tolerance :: (RealFloat a, UVec.Unbox a) => Vector a -> a+tolerance = UVec.foldl tolerance' minTolerance . UVec.filter (not . nanOrInf)   where tolerance' t v = max t $ minTolerance * v+        nanOrInf x = isInfinite x || isNaN x
src/Futhark/Transform/Rename.hs view
@@ -58,7 +58,7 @@ renameProg :: (Renameable lore, MonadFreshNames m) =>               Prog lore -> m (Prog lore) renameProg prog = modifyNameSource $-                  runRenamer $ Prog <$> mapM rename (progFunctions prog)+                  runRenamer $ Prog <$> mapM rename (progFuns prog)  -- | Rename bound variables such that each is unique.  The semantics -- of the expression is unaffected, under the assumption that the
src/Futhark/TypeCheck.hs view
@@ -464,10 +464,10 @@         local (\env -> env { envFtable = ftable }) $         checkFun fun   (ftable, _) <- runTypeM typeenv buildFtable-  sequence_ $ parMap rpar (onFunction ftable) $ progFunctions prog+  sequence_ $ parMap rpar (onFunction ftable) $ progFuns prog   where     buildFtable = do table <- initialFtable prog-                     foldM expand table $ progFunctions prog+                     foldM expand table $ progFuns prog     expand ftable (FunDef _ name ret params _)       | M.member name ftable =           bad $ DupDefinitionError name@@ -746,8 +746,8 @@ checkBasicOp (Concat i arr1exp arr2exps ressize) = do   arr1t  <- checkArrIdent arr1exp   arr2ts <- mapM checkArrIdent arr2exps-  let success = all (== (dropAt i 1 $ arrayDims arr1t)) $-                map (dropAt i 1 . arrayDims) arr2ts+  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 " ++@@ -876,7 +876,8 @@  checkType :: Checkable lore =>              TypeBase Shape u -> TypeM lore ()-checkType = mapM_ checkSubExp . arrayDims+checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int32]) d+checkType t = mapM_ checkSubExp $ arrayDims t  checkExtType :: Checkable lore =>                 TypeBase ExtShape u
src/Futhark/Util/Pretty.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | A re-export of the prettyprinting library, along with a convenience function. module Futhark.Util.Pretty        ( module Text.PrettyPrint.Mainland@@ -12,6 +13,8 @@        , oneLine        , annot        , nestedBlock+       , textwrap+       , shorten        )        where @@ -54,6 +57,10 @@ oneLine :: PP.Doc -> PP.Doc oneLine s = PP.text $ PP.displayS (PP.renderCompact s) "" +-- | Like 'text', but splits the string into words and permits line breaks between all of them.+textwrap :: String -> Doc+textwrap = folddoc (<+/>) . map text . words+ -- | Stack and prepend a list of 'Doc's to another 'Doc', separated by -- a linebreak.  If the list is empty, the second 'Doc' will be -- returned without a preceding linebreak.@@ -67,3 +74,11 @@ nestedBlock pre post body = text pre </>                             PP.indent 2 body </>                             text post++-- | Prettyprint on a single line up to at most some appropriate+-- number of characters, with trailing ... if necessary.  Used for+-- error messages.+shorten :: Pretty a => a -> Doc+shorten a | length s > 70 = text (take 70 s) <> text "..."+          | otherwise = text s+  where s = pretty a
src/Language/Futhark/Attributes.hs view
@@ -30,6 +30,8 @@    -- * Queries on patterns and params   , patternIdents+  , patternNames+  , patternMap   , patternType   , patternStructType   , patternParam@@ -62,11 +64,13 @@   , setAliases   , addAliases   , setUniqueness-  , removeShapeAnnotations-  , vacuousShapeAnnotations-  , anyDimShapeAnnotations+  , noSizes+  , addSizes+  , anySizes   , traverseDims   , DimPos(..)+  , mustBeExplicit+  , mustBeExplicitInType   , tupleRecord   , isTupleRecord   , areTupleFields@@ -75,7 +79,9 @@   , sortFields   , sortConstrs   , isTypeParam+  , isSizeParam   , combineTypeShapes+  , matchDims   , unscopeType   , onRecordField @@ -100,6 +106,7 @@   )   where +import           Control.Monad.State import           Control.Monad.Writer  hiding (Sum) import           Data.Char import           Data.Foldable@@ -138,11 +145,11 @@   case t of Array _ _ a ds ->               nub $ nestedDims (Scalar a) <> shapeDims ds             Scalar (Record fs) ->-              nub $ fold $ fmap nestedDims fs+              nub $ foldMap nestedDims fs             Scalar Prim{} ->               mempty             Scalar (Sum cs) ->-              nub $ fold $ (fmap . concatMap) nestedDims cs+              nub $ foldMap (concatMap nestedDims) cs             Scalar (Arrow _ v t1 t2) ->               filter (notV v) $ nestedDims t1 <> nestedDims t2             Scalar (TypeVar _ _ _ targs) ->@@ -155,22 +162,16 @@         notV (Named v) = (/=NamedDim (qualName v))  -- | Change the shape of a type to be just the 'Rank'.-removeShapeAnnotations :: TypeBase (DimDecl vn) as -> TypeBase () as-removeShapeAnnotations = modifyShapeAnnotations $ const ()+noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as+noSizes = first $ const ()  -- | Add size annotations that are all 'AnyDim'.-vacuousShapeAnnotations :: TypeBase () as -> TypeBase (DimDecl vn) as-vacuousShapeAnnotations = modifyShapeAnnotations $ const AnyDim+addSizes :: TypeBase () as -> TypeBase (DimDecl vn) as+addSizes = first $ const AnyDim  -- | Change all size annotations to be 'AnyDim'.-anyDimShapeAnnotations :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as-anyDimShapeAnnotations = modifyShapeAnnotations $ const AnyDim---- | Change the size annotations of a type.-modifyShapeAnnotations :: (oldshape -> newshape)-                       -> TypeBase oldshape as-                       -> TypeBase newshape as-modifyShapeAnnotations = first+anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as+anySizes = first $ const AnyDim  -- | Where does this dimension occur? data DimPos@@ -206,6 +207,35 @@         onTypeArg b (TypeArgType t loc) =           TypeArgType <$> go b t <*> pure loc +mustBeExplicitAux :: StructType -> M.Map VName Bool+mustBeExplicitAux t =+  execState (traverseDims onDim t) mempty+  where onDim PosImmediate (NamedDim d) =+          modify $ \s -> M.insertWith (&&) (qualLeaf d) False s+        onDim _ (NamedDim d) =+          modify $ M.insertWith (&&) (qualLeaf d) True+        onDim _ _ =+          return ()++-- | Figure out which of the sizes in a parameter type must be passed+-- explicitly, because their first use is as something else than just+-- an array dimension.  'mustBeExplicit' is like this function, but+-- first decomposes into parameter types.+mustBeExplicitInType :: StructType -> S.Set VName+mustBeExplicitInType t =+  S.fromList $ M.keys $ M.filter id $ mustBeExplicitAux t++-- | Figure out which of the sizes in a binding type must be passed+-- explicitly, because their first use is as something else than just+-- an array dimension.+mustBeExplicit :: StructType -> S.Set VName+mustBeExplicit bind_t =+  let (ts, ret) = unfoldFunType bind_t+      alsoRet = M.unionWith (&&) $+                M.fromList $ zip (S.toList $ typeDimNames ret) $ repeat True+  in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty ts+  where onType uses t = uses <> mustBeExplicitAux t -- Left-biased union.+ -- | Return the uniqueness of a type. uniqueness :: TypeBase shape as -> Uniqueness uniqueness (Array _ u _ _) = u@@ -225,19 +255,20 @@ -- | @diet t@ returns a description of how a function parameter of -- type @t@ might consume its argument. diet :: TypeBase shape as -> Diet-diet (Scalar (Record ets))      = RecordDiet $ fmap diet ets-diet (Scalar (Prim _))          = Observe-diet (Scalar TypeVar{})         = Observe-diet (Scalar (Arrow _ _ t1 t2)) = FuncDiet (diet t1) (diet t2)-diet (Array _ Unique _ _)       = Consume-diet (Array _ Nonunique _ _)    = Observe-diet (Scalar Sum{})             = Observe+diet (Scalar (Record ets))              = RecordDiet $ fmap diet ets+diet (Scalar (Prim _))                  = Observe+diet (Scalar (Arrow _ _ t1 t2))         = FuncDiet (diet t1) (diet t2)+diet (Array _ Unique _ _)               = Consume+diet (Array _ Nonunique _ _)            = Observe+diet (Scalar (TypeVar _ Unique _ _))    = Consume+diet (Scalar (TypeVar _ Nonunique _ _)) = Observe+diet (Scalar Sum{})                     = Observe  -- | Convert any type to one that has rank information, no alias -- information, and no embedded names. toStructural :: TypeBase dim as              -> TypeBase () ()-toStructural = flip setAliases () . modifyShapeAnnotations (const ())+toStructural = flip setAliases () . first (const ())  -- | Remove aliasing information from a type. toStruct :: TypeBase dim as@@ -336,6 +367,9 @@ isTypeParam TypeParamType{}       = True isTypeParam TypeParamDim{}        = False +isSizeParam :: TypeParamBase vn -> Bool+isSizeParam = not . isTypeParam+ -- | Combine the shape information of types as much as possible. The first -- argument is the orignal type and the second is the type of the transformed -- expression. This is necessary since the original type may contain additional@@ -345,13 +379,44 @@ combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2))   | M.keys ts1 == M.keys ts2 =       Scalar $ Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2)-combineTypeShapes (Array als1 u1 et1 shape1) (Array als2 _u2 et2 shape2)-  | Just new_shape <- unifyShapes shape1 shape2 =-      arrayOfWithAliases (combineTypeShapes (Scalar et1) (Scalar et2)-                          `setAliases` mempty)-      (als1<>als2) new_shape u1+combineTypeShapes (Scalar (Arrow als1 p1 a1 b1)) (Scalar (Arrow als2 _p2 a2 b2)) =+  Scalar $ Arrow (als1<>als2) p1 (combineTypeShapes a1 a2) (combineTypeShapes b1 b2)+combineTypeShapes (Array als1 u1 et1 shape1) (Array als2 _u2 et2 _shape2) =+  arrayOfWithAliases (combineTypeShapes (Scalar et1) (Scalar et2)+                       `setAliases` mempty)+  (als1<>als2) shape1 u1 combineTypeShapes _ new_tp = new_tp +-- | Match the dimensions of otherwise assumed-equal types.+matchDims :: (Monoid as, Monad m) =>+             (d1 -> d2 -> m d1)+          -> TypeBase d1 as -> TypeBase d2 as+          -> m (TypeBase d1 as)+matchDims onDims t1 t2 =+  case (t1, t2) of+    (Array als1 u1 et1 shape1, Array als2 u2 et2 shape2) ->+      flip setAliases (als1<>als2) <$>+      (arrayOf <$>+       matchDims onDims (Scalar et1) (Scalar et2) <*>+       onShapes shape1 shape2 <*> pure (min u1 u2))+    (Scalar (Record f1), Scalar (Record f2)) ->+      Scalar . Record <$>+      traverse (uncurry (matchDims onDims)) (M.intersectionWith (,) f1 f2)+    (Scalar (Arrow als1 p1 a1 b1), Scalar (Arrow als2 _p2 a2 b2)) ->+      Scalar <$>+      (Arrow (als1 <> als2) p1 <$> matchDims onDims a1 a2 <*> matchDims onDims b1 b2)+    (Scalar (TypeVar als1 u v targs1),+     Scalar (TypeVar als2 _ _ targs2)) ->+      Scalar . TypeVar (als1 <> als2) u v <$> zipWithM matchTypeArg targs1 targs2+    _ -> return t1++  where matchTypeArg ta@TypeArgType{} _ = return ta+        matchTypeArg a _ = return a++        onShapes shape1 shape2 =+          ShapeDecl <$> zipWithM onDims (shapeDims shape1) (shapeDims shape2)++ -- | Set the uniqueness attribute of a type.  If the type is a record -- or sum type, the uniqueness of its components will be modified. setUniqueness :: TypeBase dim as -> Uniqueness -> TypeBase dim as@@ -414,7 +479,7 @@ -- reference the bound variables, and turn any dimensions that name -- them into AnyDim instead. unscopeType :: S.Set VName -> PatternType -> PatternType-unscopeType bound_here t = modifyShapeAnnotations onDim $ t `addAliases` S.map unbind+unscopeType bound_here t = first onDim $ t `addAliases` S.map unbind   where unbind (AliasBound v) | v `S.member` bound_here = AliasFree v         unbind a = a         onDim (NamedDim qn) | qualLeaf qn `S.member` bound_here = AnyDim@@ -448,51 +513,44 @@           M.singleton (baseName name) $ t           `addAliases` S.insert (AliasBound name) typeOf (ArrayLit _ (Info t) _) = t-typeOf (StringLit _ _) =-  Array mempty Unique (Prim (Unsigned Int8)) (ShapeDecl [AnyDim])-typeOf (Range _ _ _ (Info t) _) = t-typeOf (BinOp _ _ _ _ (Info t) _) = t+typeOf (StringLit vs _) =+  Array mempty Unique (Prim (Unsigned Int8))+  (ShapeDecl [ConstDim $ genericLength vs])+typeOf (Range _ _ _ (Info t, _) _) = t+typeOf (BinOp _ _ _ _ (Info t) _ _) = t typeOf (Project _ _ (Info t) _) = t-typeOf (If _ _ _ (Info t) _) = t+typeOf (If _ _ _ (Info t, _) _) = t typeOf (Var _ (Info t) _) = t-typeOf (Ascript _ _ (Info t) _) = t-typeOf (Apply _ _ _ (Info t) _) = t+typeOf (Ascript e _ _) = typeOf e+typeOf (Coerce _ _ (Info t, _) _) = t+typeOf (Apply _ _ _ (Info t, _) _) = t typeOf (Negate e _) = typeOf e-typeOf (LetPat _ _ _ (Info t) _) = t-typeOf (LetFun name _ body _) = unscopeType (S.singleton name) $ typeOf body+typeOf (LetPat _ _ _ (Info t, _) _) = t+typeOf (LetFun _ _ _ (Info t) _) = t typeOf (LetWith _ _ _ _ _ (Info t) _) = t-typeOf (Index _ _ (Info t) _) = t+typeOf (Index _ _ (Info t, _) _) = t typeOf (Update e _ _ _) = typeOf e `setAliases` mempty typeOf (RecordUpdate _ _ _ (Info t) _) = t typeOf (Unsafe e _) = typeOf e typeOf (Assert _ e _ _) = typeOf e-typeOf (DoLoop pat _ form _ _) =-  -- We set all of the uniqueness to be unique.  This is intentional,-  -- and matches what happens for function calls.  Those arrays that-  -- really *cannot* be consumed will alias something unconsumable,-  -- and will be caught that way.-  second (`S.difference` S.map AliasBound bound_here) $-  patternType pat `setUniqueness` Unique-  where bound_here = S.map identName (patternIdents pat) <> form_bound-        form_bound =-          case form of-            For v _ -> S.singleton $ identName v-            ForIn forpat _ -> S.map identName (patternIdents forpat)-            While{} -> mempty+typeOf (DoLoop _ _ _ _ _ (Info (t, _)) _) = t typeOf (Lambda params _ _ (Info (als, t)) _) =   unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als-  where bound_here = S.map identName (mconcat $ map patternIdents params)+  where bound_here = S.map identName (mconcat $ map patternIdents params) `S.difference`+                     S.fromList (mapMaybe (named . patternParam) params)         arrow (px, tx) y = Scalar $ Arrow () px tx y+        named (Named x, _) = Just x+        named (Unnamed, _) = Nothing typeOf (OpSection _ (Info t) _) =   t-typeOf (OpSectionLeft _ _ _ (_, Info pt2) (Info ret) _)  =+typeOf (OpSectionLeft _ _ _ (_, Info pt2) (Info ret, _) _)  =   foldFunType [fromStruct pt2] ret typeOf (OpSectionRight _ _ _ (Info pt1, _) (Info ret) _) =   foldFunType [fromStruct pt1] ret typeOf (ProjectSection _ (Info t) _) = t typeOf (IndexSection _ (Info t) _) = t typeOf (Constr _ _ (Info t) _)  = t-typeOf (Match _ cs (Info t) _) =+typeOf (Match _ cs (Info t, _) _) =   unscopeType (foldMap unscopeSet cs) t   where unscopeSet (CasePat p _ _) = S.map identName $ patternIdents p @@ -577,6 +635,23 @@ patternIdents PatternLit{}              = mempty patternIdents (PatternConstr _ _ ps _ ) = mconcat $ map patternIdents ps +-- | The set of names bound in a pattern.+patternNames :: (Functor f, Ord vn) => PatternBase f vn -> S.Set vn+patternNames (Id v _ _)                = S.singleton v+patternNames (PatternParens p _)       = patternNames p+patternNames (TuplePattern pats _)     = mconcat $ map patternNames pats+patternNames (RecordPattern fs _)      = mconcat $ map (patternNames . snd) fs+patternNames Wildcard{}                = mempty+patternNames (PatternAscription p _ _) = patternNames p+patternNames PatternLit{}              = mempty+patternNames (PatternConstr _ _ ps _ ) = mconcat $ map patternNames ps++-- | A mapping from names bound in a map to their identifier.+patternMap :: (Functor f) => PatternBase f VName -> M.Map VName (IdentBase f VName)+patternMap pat =+  M.fromList $ zip (map identName idents) idents+  where idents = S.toList $ patternIdents pat+ -- | The type of values bound by the pattern. patternType :: PatternBase Info VName -> PatternType patternType (Wildcard (Info t) _)          = t@@ -933,7 +1008,7 @@ -- syntactical properties. leadingOperator :: Name -> BinOp leadingOperator s = maybe Backtick snd $ find ((`isPrefixOf` s') . fst) $-                    sortBy (flip $ comparing $ length . fst) $+                    sortOn (Down . length . fst) $                     zip (map pretty operators) operators   where s' = nameToString s         operators :: [BinOp]
src/Language/Futhark/Core.hs view
@@ -10,6 +10,7 @@    -- * Location utilities   , locStr+  , locStrRel   , prettyStacktrace    -- * Name handling@@ -24,6 +25,7 @@   , baseString   , pretty   , quote+  , pquote    -- * Special identifiers   , defaultEntryPoint@@ -124,6 +126,24 @@           first_part ++ "-" ++ show line2 ++ ":" ++ show col2       where first_part = file ++ ":" ++ show line1 ++ ":" ++ show col1 ++-- | Like 'locStr', but @locStrRel prev now@ prints the location @now@+-- with the file name left out if the same as @prev@.  This is useful+-- when printing messages that are all in the context of some+-- initially printed location (e.g. the first mention contains the+-- file name; the rest just line and column name).+locStrRel :: (Located a, Located b) => a -> b -> String+locStrRel a b =+  case (locOf a, locOf b) of+    (Loc (Pos a_file _ _ _) _, Loc (Pos b_file line1 col1 _) (Pos _ line2 col2 _))+      | a_file == b_file,+        line1 == line2 ->+          first_part ++ "-" ++ show col2+      | a_file == b_file ->+          first_part ++ "-" ++ show line2 ++ ":" ++ show col2+      where first_part = show line1 ++ ":" ++ show col1+    _ -> locStr b+ -- | Given a list of strings representing entries in the stack trace -- and the index of the frame to highlight, produce a final -- newline-terminated string for showing to the user.  This string@@ -165,4 +185,8 @@ -- These are picked to not collide with characters permitted in -- identifiers. quote :: String -> String-quote s = "`" ++ s ++ "`"+quote s = "\"" ++ s ++ "\""++-- | As 'quote', but works on prettyprinted representation.+pquote :: Doc -> Doc+pquote = dquotes
− src/Language/Futhark/Futlib.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--- | The Futhark basis library embedded embedded as strings read during--- compilation of the Futhark compiler.  The advantage is that the--- standard library can be accessed without reading it from disk, thus--- saving users from include path headaches.-module Language.Futhark.Futlib (futlib, prelude) where--import Data.FileEmbed-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified System.FilePath.Posix as Posix--import Futhark.Util (toPOSIX)---- | Futlib embedded as 'T.Text' values, one for every file.-futlib :: [(Posix.FilePath, T.Text)]-futlib = map fixup futlib_bs-  where futlib_bs = $(embedDir "futlib")-        fixup (path, s) = ("/futlib" Posix.</> toPOSIX path, T.decodeUtf8 s)---- The files intended to be implicitly imported into every Futhark--- program.  Make sure it does not depend on anything too big to be--- serialised efficiently.-prelude :: [String]-prelude = map ("/futlib/"++) ["prelude"]
src/Language/Futhark/Interpreter.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} module Language.Futhark.Interpreter   ( Ctx(..)   , Env@@ -10,17 +12,18 @@   , interpretFunction   , ExtOp(..)   , StackFrame(..)-  , typeEnv+  , typeCheckerEnv   , Value (ValuePrim, ValueArray, ValueRecord)   , fromTuple   , isEmptyArray+  , prettyEmptyArray   ) where  import Control.Monad.Trans.Maybe import Control.Monad.Free.Church import Control.Monad.Except+import Control.Monad.State import Control.Monad.Reader-import qualified Control.Monad.Fail as Fail import Data.Array import Data.Bifunctor (first) import Data.List hiding (break)@@ -30,7 +33,7 @@ import Data.Monoid hiding (Sum) import Data.Loc -import Language.Futhark hiding (Value)+import Language.Futhark hiding (Value, matchDims) import qualified Language.Futhark as F import Futhark.Representation.Primitive (intValue, floatValue) import qualified Futhark.Representation.Primitive as P@@ -59,18 +62,18 @@  type Stack = [StackFrame] +type Sizes = M.Map VName Int32+ -- | The monad in which evaluation takes place. newtype EvalM a = EvalM (ReaderT (Stack, M.Map FilePath Env)-                         (F ExtOp) a)+                         (StateT Sizes (F ExtOp)) a)   deriving (Monad, Applicative, Functor,             MonadFree ExtOp,-            MonadReader (Stack, M.Map FilePath Env))--instance Fail.MonadFail EvalM where-  fail = error+            MonadReader (Stack, M.Map FilePath Env),+            MonadState Sizes)  runEvalM :: M.Map FilePath Env -> EvalM a -> F ExtOp a-runEvalM imports (EvalM m) = runReaderT m (mempty, imports)+runEvalM imports (EvalM m) = evalStateT (runReaderT m (mempty, imports)) mempty  stacking :: SrcLoc -> Env -> EvalM a -> EvalM a stacking loc env = local $ \(ss, imports) ->@@ -87,20 +90,15 @@ lookupImport :: FilePath -> EvalM (Maybe Env) lookupImport f = asks $ M.lookup f . snd --- | A fully evaluated Futhark value.-data Value = ValuePrim !PrimValue-           | ValueArray !(Array Int Value)-           | ValueRecord (M.Map Name Value)-           | ValueFun (Value -> EvalM Value)-           | ValueSum Name [Value]+putExtSize :: VName -> Int32 -> EvalM ()+putExtSize v x = modify $ M.insert v x -instance Eq Value where-  ValuePrim x == ValuePrim y = x == y-  ValueArray x == ValueArray y = x == y-  ValueRecord x == ValueRecord y = x == y-  (ValueSum n1 vs1) == (ValueSum n2 vs2) = n1 == n2 && vs1 == vs2-  _ == _ = False+getSizes :: EvalM Sizes+getSizes = get +extSizeEnv :: EvalM Env+extSizeEnv = i32Env <$> getSizes+ prettyRecord :: Pretty a => M.Map Name a -> Doc prettyRecord m   | Just vs <- areTupleFields m =@@ -109,55 +107,175 @@       braces $ commasep $ map field $ M.toList m       where field (k, v) = ppr k <+> equals <+> ppr v +valueStructType :: ValueType -> StructType+valueStructType = first (ConstDim . fromIntegral)++-- | A shape is a tree to accomodate the case of records.  It is+-- parameterised over the representation of dimensions.+data Shape d = ShapeDim d (Shape d)+             | ShapeLeaf+             | ShapeRecord (M.Map Name (Shape d))+             | ShapeSum (M.Map Name [Shape d])+             deriving (Eq, Show, Functor, Foldable, Traversable)++type ValueShape = Shape Int32++instance Pretty d => Pretty (Shape d) where+  ppr ShapeLeaf = mempty+  ppr (ShapeDim d s) = brackets (ppr d) <> ppr s+  ppr (ShapeRecord m) = prettyRecord m+  ppr (ShapeSum cs) =+    mconcat (punctuate (text " | ") cs')+    where ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map ppr fs+          cs' = map ppConstr $ M.toList cs++emptyShape :: ValueShape -> Bool+emptyShape (ShapeDim d s) = d == 0 || emptyShape s+emptyShape _ = False++typeShape :: M.Map VName (Shape d) -> TypeBase d () -> Shape d+typeShape shapes = go+  where go (Array _ _ et shape) =+          foldr ShapeDim (go (Scalar et)) $ shapeDims shape+        go (Scalar (Record fs)) =+          ShapeRecord $ M.map go fs+        go (Scalar (Sum cs)) =+          ShapeSum $ M.map (map go) cs+        go (Scalar (TypeVar _ _ (TypeName [] v) []))+          | Just shape <- M.lookup v shapes =+              shape+        go _ =+          ShapeLeaf++structTypeShape :: M.Map VName ValueShape -> StructType -> Shape (Maybe Int32)+structTypeShape shapes = fmap dim . typeShape shapes'+  where dim (ConstDim d) = Just $ fromIntegral d+        dim _ = Nothing+        shapes' = M.map (fmap $ ConstDim . fromIntegral) shapes++resolveTypeParams :: [VName] -> StructType -> StructType -> Env+resolveTypeParams names = match+  where match (Scalar (TypeVar _ _ tn _)) t+          | typeLeaf tn `elem` names =+              typeEnv $ M.singleton (typeLeaf tn) t+        match (Scalar (Record poly_fields)) (Scalar (Record fields)) =+          mconcat $ M.elems $+          M.intersectionWith match poly_fields fields+        match (Scalar (Sum poly_fields)) (Scalar (Sum fields)) =+          mconcat $ map mconcat $ M.elems $+          M.intersectionWith (zipWith match) poly_fields fields+        match (Scalar (Arrow _ _  poly_t1 poly_t2)) (Scalar (Arrow _ _ t1 t2)) =+          match poly_t1 t1 <> match poly_t2 t2+        match poly_t t+          | d1 : _ <- shapeDims (arrayShape poly_t),+            d2 : _ <- shapeDims (arrayShape t) =+              matchDims d1 d2 <> match (stripArray 1 poly_t) (stripArray 1 t)+        match _ _ = mempty++        matchDims (NamedDim (QualName _ d1)) (ConstDim d2)+          | d1 `elem` names =+              i32Env $ M.singleton d1 $ fromIntegral d2+        matchDims _ _ = mempty++resolveExistentials :: [VName] -> StructType -> ValueShape -> M.Map VName Int32+resolveExistentials names = match+  where match (Scalar (Record poly_fields)) (ShapeRecord fields) =+          mconcat $ M.elems $+          M.intersectionWith match poly_fields fields+        match (Scalar (Sum poly_fields)) (ShapeSum fields) =+          mconcat $ map mconcat $ M.elems $+          M.intersectionWith (zipWith match) poly_fields fields+        match poly_t (ShapeDim d2 rowshape)+          | d1 : _ <- shapeDims (arrayShape poly_t) =+              matchDims d1 d2 <> match (stripArray 1 poly_t) rowshape+        match _ _ = mempty++        matchDims (NamedDim (QualName _ d1)) d2+          | d1 `elem` names = M.singleton d1 d2+        matchDims _ _ = mempty++-- | A fully evaluated Futhark value.+data Value = ValuePrim !PrimValue+           | ValueArray ValueShape !(Array Int Value)+             -- Stores the full shape.+           | ValueRecord (M.Map Name Value)+           | ValueFun (Value -> EvalM Value)+           | ValueSum ValueShape Name [Value]+             -- Stores the full shape.++instance Eq Value where+  ValuePrim x == ValuePrim y = x == y+  ValueArray _ x == ValueArray _ y = x == y+  ValueRecord x == ValueRecord y = x == y+  ValueSum _ n1 vs1 == ValueSum _ n2 vs2 = n1 == n2 && vs1 == vs2+  _ == _ = False+ instance Pretty Value where   ppr (ValuePrim v)  = ppr v-  ppr (ValueArray a) =+  ppr (ValueArray _ a) =     let elements  = elems a -- [Value]         (x:_)     = elements         separator = case x of-                      (ValueArray _) -> comma <> line+                      ValueArray _ _ -> comma <> line                       _              -> comma <> space      in brackets $ cat $ punctuate separator (map ppr elements)    ppr (ValueRecord m) = prettyRecord m   ppr ValueFun{} = text "#<fun>"-  ppr (ValueSum n vs) = text "#" <> sep (ppr n : map ppr vs)---- | Create an array value; failing if that would result in an--- irregular array.-mkArray :: [Value] -> Maybe Value-mkArray vs =-  case vs of [] -> Just $ toArray' vs-             v:_ | all ((==valueShape v) . valueShape) vs -> Just $ toArray' vs-                 | otherwise -> Nothing---- | A shape is a tree to accomodate the case of records.-data Shape = ShapeDim Int32 Shape-           | ShapeLeaf-           | ShapeRecord (M.Map Name Shape)-           deriving (Eq, Show)--instance Pretty Shape where-  ppr ShapeLeaf = mempty-  ppr (ShapeDim d s) = brackets (ppr d) <> ppr s-  ppr (ShapeRecord m) = prettyRecord m--emptyShape :: Shape -> Bool-emptyShape ShapeLeaf = False-emptyShape (ShapeDim d s) = d == 0 || emptyShape s-emptyShape (ShapeRecord fs) = any emptyShape fs+  ppr (ValueSum _ n vs) = text "#" <> sep (ppr n : map ppr vs) -valueShape :: Value -> Shape-valueShape (ValueArray arr) = ShapeDim (arrayLength arr) $-                              case elems arr of-                                []  -> ShapeLeaf-                                v:_ -> valueShape v+valueShape :: Value -> ValueShape+valueShape (ValueArray shape _) = shape valueShape (ValueRecord fs) = ShapeRecord $ M.map valueShape fs+valueShape (ValueSum shape _ _) = shape valueShape _ = ShapeLeaf +checkShape :: Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape+checkShape (ShapeDim Nothing shape1) (ShapeDim d2 shape2) =+  ShapeDim d2 <$> checkShape shape1 shape2+checkShape (ShapeDim (Just d1) shape1) (ShapeDim d2 shape2) = do+  guard $ d1 == d2+  ShapeDim d2 <$> checkShape shape1 shape2+checkShape (ShapeDim d1 shape1) ShapeLeaf =+  -- This case is for handling polymorphism, when a function doesn't+  -- know that the array it produced actually has more dimensions.+  ShapeDim (fromMaybe 0 d1) <$> checkShape shape1 ShapeLeaf+checkShape (ShapeRecord shapes1) (ShapeRecord shapes2) =+  ShapeRecord <$> sequence (M.intersectionWith checkShape shapes1 shapes2)+checkShape (ShapeRecord shapes1) ShapeLeaf =+  Just $ fromMaybe 0 <$> ShapeRecord shapes1+checkShape (ShapeSum shapes1) (ShapeSum shapes2) =+  ShapeSum <$> sequence (M.intersectionWith (zipWithM checkShape) shapes1 shapes2)+checkShape (ShapeSum shapes1) ShapeLeaf =+  Just $ fromMaybe 0 <$> ShapeSum shapes1+checkShape _ shape2 =+  Just shape2++-- | Does the value correspond to an empty array? isEmptyArray :: Value -> Bool isEmptyArray = emptyShape . valueShape +-- | String representation of an empty array with the provided element+-- type.  This is pretty ad-hoc - don't expect good results unless the+-- element type is a primitive.+prettyEmptyArray :: TypeBase () () -> Value -> String+prettyEmptyArray t v =+  "empty(" ++ dims (valueShape v) ++ pretty t' ++ ")"+  where t' = stripArray (arrayRank t) t+        dims (ShapeDim n rowshape) =+          "[" ++ pretty n ++ "]" ++ dims rowshape+        dims _ = ""++-- | Create an array value; failing if that would result in an+-- irregular array.+mkArray :: TypeBase Int32 () -> [Value] -> Maybe Value+mkArray t [] =+  return $ toArray (typeShape mempty t) []+mkArray _ (v:vs) = do+  let v_shape = valueShape v+  guard $ all ((==v_shape) . valueShape) vs+  return $ toArray' v_shape $ v:vs+ arrayLength :: Integral int => Array Int Value -> int arrayLength = fromIntegral . (+1) . snd . bounds @@ -205,6 +323,8 @@  -- | A TermValue with a 'Nothing' type annotation is an intrinsic. data TermBinding = TermValue (Maybe T.BoundV) Value+                 | TermPoly (Maybe T.BoundV) (StructType -> EvalM Value)+                   -- ^ A polymorphic value that must be instantiated.                  | TermModule Module  data Module = Module Env@@ -212,7 +332,7 @@  data Env = Env { envTerm :: M.Map VName TermBinding                , envType :: M.Map VName T.TypeBinding-               , envShapes :: M.Map VName Shape+               , envShapes :: M.Map VName ValueShape                  -- ^ A mapping from type parameters to the shapes of                  -- the value to which they were initially bound.                }@@ -238,6 +358,18 @@                , envShapes = mempty                } +typeEnv :: M.Map VName StructType -> Env+typeEnv m = Env { envTerm = mempty+                , envType = M.map tbind m+                , envShapes = mempty+                }+  where tbind = T.TypeAbbr Unlifted []++i32Env :: M.Map VName Int32 -> Env+i32Env = valEnv . M.map f+  where f x = (Just $ T.BoundV [] $ Scalar $ Prim $ Signed Int32,+               ValuePrim $ SignedValue $ Int32Value x)+ instance Show InterpreterError where   show (InterpreterError s) = s @@ -254,8 +386,8 @@   top <- fromMaybe noLoc . maybeHead . drop 1 <$> stacktrace   liftF $ ExtOpTrace top (pretty v) () -typeEnv :: Env -> T.Env-typeEnv env =+typeCheckerEnv :: Env -> T.Env+typeCheckerEnv env =   -- FIXME: some shadowing issues are probably not right here.   let valMap (TermValue (Just t) _) = Just t       valMap _ = Nothing@@ -276,19 +408,19 @@     Nothing -> return ()     Just stack' -> liftF $ ExtOpBreak stack' () -fromArray :: Value -> [Value]-fromArray (ValueArray as) = elems as+fromArray :: Value -> (ValueShape, [Value])+fromArray (ValueArray shape as) = (shape, elems as) fromArray v = error $ "Expected array value, but found: " ++ pretty v --- | This is where we enforce the regularity constraint for arrays.-toArray :: [Value] -> EvalM Value-toArray = maybe (bad noLoc mempty "irregular array") return . mkArray+toArray :: ValueShape -> [Value] -> Value+toArray shape vs = ValueArray shape (listArray (0, length vs - 1) vs) -toArray' :: [Value] -> Value-toArray' vs = ValueArray (listArray (0, length vs - 1) vs)+toArray' :: ValueShape -> [Value] -> Value+toArray' rowshape vs = ValueArray shape (listArray (0, length vs - 1) vs)+  where shape = ShapeDim (genericLength vs) rowshape  apply :: SrcLoc -> Env -> Value -> Value -> EvalM Value-apply loc env (ValueFun f) v = stacking loc env $ f v+apply loc env (ValueFun f) v = stacking loc env (f v) apply _ _ f _ = error $ "Cannot apply non-function: " ++ pretty f  apply2 :: SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value@@ -299,110 +431,38 @@ matchPattern env p v = do   m <- runMaybeT $ patternMatch env p v   case m of-    Nothing    -> error $ "matchPattern: missing case for " ++ pretty p ++ " and " ++ pretty v+    Nothing   -> error $ "matchPattern: missing case for " ++ pretty p ++ " and " ++ pretty v     Just env' -> return env'  patternMatch :: Env -> Pattern -> Value -> MaybeT EvalM Env patternMatch env (Id v (Info t) _) val =-  lift $ pure $ valEnv (M.singleton v (Just $ T.BoundV [] $ toStruct t, val)) <> env+  lift $ pure $+  valEnv (M.singleton v (Just $ T.BoundV [] $ toStruct t, val)) <> env patternMatch env Wildcard{} _ =   lift $ pure env patternMatch env (TuplePattern ps _) (ValueRecord vs)   | length ps == length vs' =-    foldM (\env' (p,v) -> patternMatch env' p v) env $-    zip ps (map snd $ sortFields vs)+      foldM (\env' (p,v) -> patternMatch env' p v) env $+      zip ps (map snd $ sortFields vs)     where vs' = sortFields vs patternMatch env (RecordPattern ps _) (ValueRecord vs)   | length ps == length vs' =-    foldM (\env' (p,v) -> patternMatch env' p v) env $-    zip (map snd $ sortFields $ M.fromList ps) (map snd $ sortFields vs)+      foldM (\env' (p,v) -> patternMatch env' p v) env $+      zip (map snd $ sortFields $ M.fromList ps) (map snd $ sortFields vs)     where vs' = sortFields vs patternMatch env (PatternParens p _) v = patternMatch env p v-patternMatch env (PatternAscription p td loc) v = do-  let t = evalType env $ unInfo $ expandedType td-  case matchValueToType env t v of-    Left err -> lift $ bad loc env err-    Right env' -> patternMatch env' p v+patternMatch env (PatternAscription p _ _) v =+  patternMatch env p v patternMatch env (PatternLit e _ _) v = do   v' <- lift $ eval env e   if v == v'     then pure env     else mzero-patternMatch env (PatternConstr n _ ps _) (ValueSum n' vs)+patternMatch env (PatternConstr n _ ps _) (ValueSum _ n' vs)   | n == n' =-    foldM (\env' (p,v) -> patternMatch env' p v) env $ zip ps vs+      foldM (\env' (p,v) -> patternMatch env' p v) env $ zip ps vs patternMatch _ _ _ = mzero --- | For matching size annotations (the actual type will have been--- verified by the type checker).  It is assumed that previously--- unbound names are in binding position here.-matchValueToType :: Env-                 -> StructType-                 -> Value-                 -> Either String Env--matchValueToType env t@(Scalar (TypeVar _ _ tn [])) val-  | Just shape <- M.lookup (typeLeaf tn) $ envShapes env,-    shape /= valueShape val =-      Left $ "Value passed for type parameter " <> quote (prettyName (typeLeaf tn)) <>-      " does not match shape " <> pretty shape <>-      " of previously observed value."-  | Nothing <- M.lookup (typeLeaf tn) $ envShapes env =-      matchValueToType (tnenv <> env) t val-      where tnenv = Env mempty mempty $ M.singleton (typeLeaf tn) (valueShape val)--matchValueToType env t@(Array _ _ _ (ShapeDecl ds@(d:_))) val@(ValueArray arr) =-  case d of-    NamedDim v-      | Just x <- look v ->-          if x == arr_n-          then continue env-          else emptyOrWrong $ quote (pretty v) <> " (" <> pretty x <> ")"-      | otherwise ->-          continue $-          valEnv (M.singleton (qualLeaf v)-                   (Just $ T.BoundV [] $ Scalar $ Prim $ Signed Int32,-                    ValuePrim $ SignedValue $ Int32Value arr_n))-          <> env-    AnyDim -> continue env-    ConstDim x-      | fromIntegral x == arr_n -> continue env-      | otherwise -> emptyOrWrong $ pretty x-  where arr_n = arrayLength arr--        look v-          | Just (TermValue _ (ValuePrim (SignedValue (Int32Value x)))) <--              lookupVar v env = Just x-          | otherwise = Nothing--        continue env' = case elems arr of-          [] -> return env'-          v:_ -> matchValueToType env' (stripArray 1 t) v--        -- Empty arrays always match if nothing else does.-        emptyOrWrong x-          | any zeroDim ds, emptyShape (valueShape val) =-              Right env-          | otherwise = wrong x--        wrong x = Left $ "Size annotation " <> x <>-                  " does not match observed size " <> pretty arr_n <> "."--        zeroDim (NamedDim v) = isNothing (look v) || Just 0 == look v-        zeroDim AnyDim = True-        zeroDim (ConstDim x) = x == 0--matchValueToType env (Scalar (Record fs)) (ValueRecord arr) =-  foldM (\env' (t, v) -> matchValueToType env' t v) env $-  M.intersectionWith (,) fs arr--matchValueToType env _ _ = return env--bindToZero :: [VName] -> Env-bindToZero = valEnv . M.fromList . map f-  where f v = (v, (Just $ T.BoundV [] $ Scalar $ Prim $ Signed Int32,-                   ValuePrim $ SignedValue $ Int32Value 0))- data Indexing = IndexingFix Int32               | IndexingSlice (Maybe Int32) (Maybe Int32) (Maybe Int32) @@ -420,8 +480,8 @@     maybe mempty ppr i <> text ":"  indexesFor :: Maybe Int32 -> Maybe Int32 -> Maybe Int32-           -> Array Int Value -> Maybe [Int]-indexesFor start end stride arr+           -> Int32 -> Maybe [Int]+indexesFor start end stride n   | (start', end', stride') <- slice,     end' == start' || signum' (end' - start') == signum' stride',     stride' /= 0,@@ -430,9 +490,7 @@       Just $ map fromIntegral is   | otherwise =       Nothing-  where n = arrayLength arr--        inBounds i = i >= 0 && i < n+  where inBounds i = i >= 0 && i < n          slice =           case (start, end, stride) of@@ -454,34 +512,43 @@ signum' 0 = 1 signum' x = signum x +indexShape :: [Indexing] -> ValueShape -> ValueShape+indexShape (IndexingFix{}:is) (ShapeDim _ shape) =+  indexShape is shape+indexShape (IndexingSlice start end stride:is) (ShapeDim d shape) =+  ShapeDim n $ indexShape is shape+  where n = maybe 0 genericLength $ indexesFor start end stride d+indexShape _ shape =+  shape+ indexArray :: [Indexing] -> Value -> Maybe Value-indexArray (IndexingFix i:is) (ValueArray arr)+indexArray (IndexingFix i:is) (ValueArray _ arr)   | i >= 0, i < n =       indexArray is $ arr ! fromIntegral i   | otherwise =       Nothing   where n = arrayLength arr-indexArray (IndexingSlice start end stride:is) (ValueArray arr) = do-  js <- indexesFor start end stride arr-  toArray' <$> mapM (indexArray is . (arr!)) js+indexArray (IndexingSlice start end stride:is) (ValueArray (ShapeDim _ rowshape) arr) = do+  js <- indexesFor start end stride $ arrayLength arr+  toArray' (indexShape is rowshape) <$> mapM (indexArray is . (arr!)) js indexArray _ v = Just v  updateArray :: [Indexing] -> Value -> Value -> Maybe Value-updateArray (IndexingFix i:is) (ValueArray arr) v+updateArray (IndexingFix i:is) (ValueArray shape arr) v   | i >= 0, i < n = do       v' <- updateArray is (arr ! i') v-      Just $ ValueArray $ arr // [(i', v')]+      Just $ ValueArray shape $ arr // [(i', v')]   | otherwise =       Nothing   where n = arrayLength arr         i' = fromIntegral i-updateArray (IndexingSlice start end stride:is) (ValueArray arr) (ValueArray v) = do-  arr_is <- indexesFor start end stride arr+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 $ foldM update arr $ zip arr_is $ elems v+  fmap (ValueArray shape) $ foldM update arr $ zip arr_is $ elems v updateArray _ _ v = Just v  evalDimIndex :: Env -> DimIndex -> EvalM Indexing@@ -499,12 +566,6 @@             pretty (valueShape arr) <> "."   maybe oob return $ indexArray is arr -evalTermVar :: Env -> QualName VName -> EvalM Value-evalTermVar env qv =-  case lookupVar qv env of-    Just (TermValue _ v) -> return v-    _ -> error $ quote (pretty qv) <> " is not bound to a value."- -- | Expand type based on information that was not available at -- type-checking time (the structure of abstract types). evalType :: Env -> StructType -> StructType@@ -542,40 +603,91 @@         matchPtoA _ _ = mempty evalType env (Scalar (Sum cs)) = Scalar $ Sum $ (fmap . fmap) (evalType env) cs -evalFunction :: Env -> [TypeParam] -> [Pattern] -> Exp-             -> (Aliasing, StructType) -> SrcLoc -> EvalM Value+evalTermVar :: Env -> QualName VName -> StructType -> EvalM Value+evalTermVar env qv t =+  case lookupVar qv env of+    Just (TermPoly _ v) -> do size_env <- extSizeEnv+                              v $ evalType (size_env <> env) t+    Just (TermValue _ v) -> return v+    _ -> error $ "`" <> pretty qv <> "` is not bound to a value." +typeValueShape :: Env -> StructType -> EvalM ValueShape+typeValueShape env t = do+  size_env <- extSizeEnv+  let t' = evalType (size_env <> env) t+  case traverse dim $ typeShape mempty t' of+    Nothing -> error $ "typeValueShape: failed to fully evaluate type " ++ pretty t'+    Just shape -> return shape+  where dim (ConstDim x) = Just $ fromIntegral x+        dim _ = Nothing++evalFunction :: Env -> [VName] -> [Pattern] -> Exp -> StructType -> EvalM Value+ -- We treat zero-parameter lambdas as simply an expression to -- evaluate immediately.  Note that this is *not* the same as a lambda -- that takes an empty tuple '()' as argument!  Zero-parameter lambdas -- can never occur in a well-formed Futhark program, but they are -- convenient in the interpreter.-evalFunction env tparams [] body (_, t) loc = do-  -- All remaining size parameters that have not yet been assigned a-  -- value (because they were inner dimensions of empty arrays) are-  -- now assigned a zero.-  let unbound_dims = bindToZero $ map typeParamName $ filter isDimParam tparams-  v <- eval (env <> unbound_dims) body-  case (t, v) of-    (Scalar (Arrow _ _ _ rt), ValueFun f) ->-      return $ ValueFun $ \arg -> do r <- f arg-                                     match (evalType env rt) r-    _ -> match t v-  where match vt v =-          case matchValueToType env vt v of-            Right _ -> return v-            Left err ->-              bad loc env $ "Value " <> quote (pretty v) <>-              " cannot match type " <> quote (pretty vt) <> ": " ++ err--        isDimParam TypeParamDim{} = True-        isDimParam _ = False+evalFunction env _ [] body rettype =+  -- Eta-expand the rest to make any sizes visible.+  etaExpand [] env rettype+  where etaExpand vs env' (Scalar (Arrow _ _ pt rt)) =+          return $ ValueFun $ \v -> do+          env'' <- matchPattern env' (Wildcard (Info $ fromStruct pt) noLoc) v+          etaExpand (v:vs) env'' rt+        etaExpand vs env' _ = do+          f <- eval env' body+          foldM (apply noLoc mempty) f $ reverse vs -evalFunction env tparams (p:ps) body (als, ret) loc =+evalFunction env missing_sizes (p:ps) body rettype =   return $ ValueFun $ \v -> do     env' <- matchPattern env p v-    evalFunction env' tparams ps body (als, ret) loc+    -- Fix up the last sizes, if any.+    let env'' | null missing_sizes = env'+              | otherwise = env' <>+                            i32Env (resolveExistentials missing_sizes+                                    (patternStructType p) (valueShape v))+    evalFunction env'' missing_sizes ps body rettype +evalFunctionBinding :: Env+                    -> [TypeParam] -> [Pattern] -> StructType -> [VName] -> Exp+                    -> EvalM TermBinding+evalFunctionBinding env tparams ps ret retext fbody = do+  let ret' = evalType env ret+      arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt+      ftype = foldr (arrow . patternParam) ret' ps++  -- Distinguish polymorphic and non-polymorphic bindings here.+  if null tparams+  then TermValue (Just $ T.BoundV [] ftype) <$>+       (returned env ret retext =<< evalFunction env [] ps fbody ret')+  else return $ TermPoly (Just $ T.BoundV [] ftype) $ \ftype' -> do+         let tparam_names = map typeParamName tparams+             env' = resolveTypeParams tparam_names ftype ftype' <> env++             -- In some cases (abstract lifted types) there may be+             -- missing sizes that were not fixed by the type+             -- instantiation.  These will have to be set by looking+             -- at the actual function arguments.+             missing_sizes =+               filter (`M.notMember` envTerm env') $+               map typeParamName (filter isSizeParam tparams)+         returned env ret retext =<< evalFunction env' missing_sizes ps fbody ret'++evalArg :: Env -> Exp -> Maybe VName -> EvalM Value+evalArg env e ext = do+  v <- eval env e+  case ext of Just ext' -> putExtSize ext' $ asInt32 v+              Nothing -> return ()+  return v++returned :: Env -> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value+returned _ _ [] v = return v+returned env ret retext v = do+  mapM_ (uncurry putExtSize) $ M.toList $+    resolveExistentials retext (evalType env $ toStruct ret) $ valueShape v+  return v+ eval :: Env -> Exp -> EvalM Value  eval _ (Literal v _) = return $ ValuePrim v@@ -595,12 +707,20 @@           v <- eval env $ Var (qualName k) t loc           return (baseName k, v) -eval env (ArrayLit vs _ _) = toArray =<< mapM (eval env) vs- eval _ (StringLit vs _) =-  toArray $ map (ValuePrim . UnsignedValue . Int8Value . fromIntegral) vs+  return $ toArray' ShapeLeaf $+  map (ValuePrim . UnsignedValue . Int8Value . fromIntegral) vs -eval env (Range start maybe_second end (Info t) loc) = do+eval env (ArrayLit [] (Info t) _) = do+  t' <- typeValueShape env $ toStruct t+  return $ toArray t' []++eval env (ArrayLit (v:vs) _ _) = do+  v' <- eval env v+  vs' <- mapM (eval env) vs+  return $ toArray' (valueShape v') (v':vs')++eval env (Range start maybe_second end (Info t, Info retext) loc) = do   start' <- asInteger <$> eval env start   maybe_second' <- traverse (fmap asInteger . eval env) maybe_second   end' <- traverse (fmap asInteger . eval env) end@@ -626,7 +746,8 @@             (x-1, second' - start', start' <= x && second' > start')    if ok-    then toArray $ map toInt [start',start'+step..end_adj]+    then returned env t retext $+         toArray' ShapeLeaf $ map toInt [start',start'+step..end_adj]     else bad loc env $ badRange start' maybe_second' end'    where toInt =@@ -648,26 +769,28 @@              UpToExclusive x -> "..<"++ pretty x) ++           " is invalid." -eval env (Var qv _ _) = evalTermVar env qv+eval env (Var qv (Info t) _) = evalTermVar env qv (toStruct t) -eval env (Ascript e td _ loc) = do-  v <- eval env e+eval env (Ascript e _ _ ) = eval env e++eval env (Coerce e td (Info ret, Info retext) loc) = do+  v <- returned env ret retext =<< eval env e   let t = evalType env $ unInfo $ expandedType td-  case matchValueToType env t v of-    Right _ -> return v-    Left err -> bad loc env $ "Value " <> quote (pretty v) <> " cannot match shape of type " <>-                quote (pretty (declaredType td)) <> " (" <> quote (pretty t) <> "): " ++ err+  case checkShape (structTypeShape (envShapes env) t) (valueShape v) of+    Just _ -> return v+    Nothing ->+      bad loc env $ "Value `" <> pretty v <> "` of shape `" ++ pretty (valueShape v) +++      "` cannot match shape of type `" <>+      pretty (declaredType td) <> "` (`" <> pretty t <> "`)" -eval env (LetPat p e body _ _) = do+eval env (LetPat p e body (Info ret, Info retext) _) = do   v <- eval env e   env' <- matchPattern env p v-  eval env' body+  returned env ret retext =<< eval env' body -eval env (LetFun f (tparams, pats, _, Info ret, fbody) body loc) = do-  v <- evalFunction env tparams pats fbody (mempty, ret) loc-  let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt-      ftype = T.BoundV [] $ foldr (arrow . patternParam) ret pats-  eval (valEnv (M.singleton f (Just ftype, v)) <> env) body+eval env (LetFun f (tparams, ps, _, Info ret, fbody) body _ _) = do+  binding <- evalFunctionBinding env tparams ps ret [] fbody+  eval (env { envTerm = M.insert f binding $ envTerm env }) body  eval _ (IntLit v (Info t) _) =   case t of@@ -685,7 +808,9 @@       return $ ValuePrim $ FloatValue $ floatValue ft v     _ -> error $ "eval: nonsensical type for float literal: " ++ pretty t -eval env (BinOp (op, _) op_t (x, _) (y, _) _ loc)+eval env (BinOp (op, _) op_t+          (x, Info (_, xext)) (y, Info (_, yext))+          (Info t) (Info retext) loc)   | baseString (qualLeaf op) == "&&" = do       x' <- asBool <$> eval env x       if x'@@ -698,18 +823,21 @@         else eval env y   | otherwise = do       op' <- eval env $ Var op op_t loc-      x' <- eval env x-      y' <- eval env y-      apply2 loc env op' x' y'+      x' <- evalArg env x xext+      y' <- evalArg env y yext+      returned env t retext =<< apply2 loc env op' x' y' -eval env (If cond e1 e2 _ _) = do+eval env (If cond e1 e2 (Info ret, Info retext) _) = do   cond' <- asBool <$> eval env cond-  if cond' then eval env e1 else eval env e2+  returned env ret retext =<<+    if cond' then eval env e1 else eval env e2 -eval env (Apply f x _ _ loc) = do+eval env (Apply f x (Info (_, ext)) (Info t, Info retext) loc) = do+  -- It is important that 'x' is evaluated first in order to bring any+  -- sizes into scope that may be used in the type of 'f'.+  x' <- evalArg env x ext   f' <- eval env f-  x' <- eval env x-  apply loc env f' x'+  returned env t retext =<< apply loc env f' x'  eval env (Negate e _) = do   ev <- eval env e@@ -724,12 +852,12 @@     ValuePrim (UnsignedValue (Int64Value v)) -> return $ UnsignedValue $ Int64Value (-v)     ValuePrim (FloatValue (Float32Value v)) -> return $ FloatValue $ Float32Value (-v)     ValuePrim (FloatValue (Float64Value v)) -> return $ FloatValue $ Float64Value (-v)-    _ -> fail $ "Cannot negate " ++ pretty ev+    _ -> error $ "Cannot negate " ++ pretty ev -eval env (Index e is _ loc) = do+eval env (Index e is (Info t, Info retext) loc) = do   is' <- mapM (evalDimIndex env) is   arr <- eval env e-  evalIndex loc env is' arr+  returned env t retext =<< evalIndex loc env is' arr  eval env (Update src is v loc) =   maybe oob return =<<@@ -745,9 +873,10 @@         update _ _ _ = error "eval RecordUpdate: invalid value."  eval env (LetWith dest src is v body _ loc) = do+  let Ident src_vn (Info src_t) _ = src   dest' <- maybe oob return =<<     updateArray <$> mapM (evalDimIndex env) is <*>-    evalTermVar env (qualName $ identName src) <*> eval env v+    evalTermVar env (qualName src_vn) (toStruct src_t) <*> eval env v   let t = T.BoundV [] $ toStruct $ unInfo $ identType dest   eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body   where oob = bad loc env "Bad update"@@ -757,39 +886,48 @@ -- that takes an empty tuple '()' as argument!  Zero-parameter lambdas -- can never occur in a well-formed Futhark program, but they are -- convenient in the interpreter.-eval env (Lambda ps body _ (Info (als, ret)) loc) =-  evalFunction env [] ps body (als, ret) loc+eval env (Lambda ps body _ (Info (_, rt)) _) =+  evalFunction env [] ps body rt -eval env (OpSection qv _  _) = evalTermVar env qv+eval env (OpSection qv (Info t) _) = evalTermVar env qv $ toStruct t -eval env (OpSectionLeft qv _ e _ _ loc) =-  join $ apply loc env <$> evalTermVar env qv <*> eval env e+eval env (OpSectionLeft qv _ e (Info (_, argext), _) (Info t, Info retext) loc) = do+  v <- evalArg env e argext+  f <- evalTermVar env qv (toStruct t)+  returned env t retext =<< apply loc env f v -eval env (OpSectionRight qv _ e _ _ loc) = do-  f <- evalTermVar env qv-  y <- eval env e-  return $ ValueFun $ \x -> join $ apply loc env <$> apply loc env f x <*> pure y+eval env (OpSectionRight qv _ e (Info _, Info (_, argext)) (Info t) loc) = do+  y <- evalArg env e argext+  return $ ValueFun $ \x -> do+    f <- evalTermVar env qv $ toStruct t+    apply2 loc env f x y  eval env (IndexSection is _ loc) = do   is' <- mapM (evalDimIndex env) is   return $ ValueFun $ evalIndex loc env is' -eval _ (ProjectSection ks _ _) = return $ ValueFun $ flip (foldM walk) ks+eval _ (ProjectSection ks _ _) =+  return $ ValueFun $ flip (foldM walk) ks   where walk (ValueRecord fs) f           | Just v' <- M.lookup f fs = return v'-        walk _ _ = fail "Value does not have expected field."+        walk _ _ = error "Value does not have expected field." -eval env (DoLoop pat init_e form body _) = do+eval env (DoLoop sparams pat init_e form body (Info (ret, retext)) _) = do   init_v <- eval env init_e-  case form of For iv bound -> do-                 bound' <- asSigned <$> eval env bound-                 forLoop (identName iv) bound' (zero bound') init_v-               ForIn in_pat in_e -> do-                 in_vs <- fromArray <$> eval env in_e-                 foldM (forInLoop in_pat) init_v in_vs-               While cond ->-                 whileLoop cond init_v-  where withLoopParams = matchPattern env pat+  returned env ret retext =<<+    case form of For iv bound -> do+                   bound' <- asSigned <$> eval env bound+                   forLoop (identName iv) bound' (zero bound') init_v+                 ForIn in_pat in_e -> do+                   (_, in_vs) <- fromArray <$> eval env in_e+                   foldM (forInLoop in_pat) init_v in_vs+                 While cond ->+                   whileLoop cond init_v+  where withLoopParams v =+          let sparams' =+                resolveExistentials sparams+                (patternStructType pat) (valueShape v)+          in matchPattern (i32Env sparams' <> env) pat v          inc = (`P.doAdd` Int64Value 1)         zero = (`P.doMul` Int64Value 0)@@ -818,7 +956,7 @@   v <- eval env e   case v of     ValueRecord fs | Just v' <- M.lookup f fs -> return v'-    _ -> fail "Value does not have expected field."+    _ -> error "Value does not have expected field."  eval env (Unsafe e _) = eval env e @@ -827,15 +965,16 @@   unless cond $ bad loc env s   eval env e -eval env (Constr c es _ _) = do+eval env (Constr c es (Info t) _) = do   vs <- mapM (eval env) es-  return $ ValueSum c vs+  shape <- typeValueShape env $ toStruct t+  return $ ValueSum shape c vs -eval env (Match e cs _ _) = do+eval env (Match e cs (Info ret, Info retext) _) = do   v <- eval env e-  match v $ NE.toList cs+  returned env ret retext =<< match v (NE.toList cs)   where match _ [] =-          fail "Pattern match failure."+          error "Pattern match failure."         match v (c:cs') = do           c' <- evalCase v env c           case c' of@@ -862,6 +1001,7 @@     onModule (ModuleFun f) =       ModuleFun $ \m -> onModule <$> f (substituteInModule rev_substs m)     onTerm (TermValue t v) = TermValue t v+    onTerm (TermPoly t v) = TermPoly t v     onTerm (TermModule m) = TermModule $ onModule m     onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ first onDim t     onDim (NamedDim v) = NamedDim $ replaceQ v@@ -907,22 +1047,24 @@     Just (se, rsubsts) -> ModAscript e se rsubsts loc  evalModExp env (ModApply f e (Info psubst) (Info rsubst) _) = do-  ModuleFun f' <- evalModExp env f-  e' <- evalModExp env e-  substituteInModule rsubst <$> f' (substituteInModule psubst e')+  f' <- evalModExp env f+  case f' of+    ModuleFun f'' -> do+      e' <- evalModExp env e+      substituteInModule rsubst <$> f'' (substituteInModule psubst e')+    _ -> error "Expected ModuleFun."  evalDec :: Env -> Dec -> EvalM Env -evalDec env (ValDec (ValBind _ v _ (Info t) tps ps def _ loc)) = do-  let t' = evalType env t-      arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt-      ftype = T.BoundV [] $ foldr (arrow . patternParam) t' ps-  val <- evalFunction env tps ps def (mempty, t') loc-  return $ valEnv (M.singleton v (Just ftype, val)) <> env+evalDec env (ValDec (ValBind _ v _ (Info (ret, retext)) tparams ps fbody _ _)) = do+  binding <- evalFunctionBinding env tparams ps ret retext fbody+  return $ env { envTerm = M.insert v binding $ envTerm env }  evalDec env (OpenDec me _) = do-  Module me' <- evalModExp env me-  return $ me' <> env+  me' <- evalModExp env me+  case me' of+    Module me'' -> return $ me'' <> env+    _ -> error "Expected Module"  evalDec env (ImportDec name name' loc) =   evalDec env $ LocalDec (OpenDec (ModImport name name' loc) loc) loc@@ -1015,7 +1157,8 @@     fun1 f =       TermValue Nothing $ ValueFun $ \x -> f x     fun2 f =-      TermValue Nothing $ ValueFun $ \x -> return $ ValueFun $ \y -> f x y+      TermValue Nothing $ ValueFun $ \x ->+      return $ ValueFun $ \y -> f x y     fun2t f =       TermValue Nothing $ ValueFun $ \v ->       case fromTuple v of Just [x,y] -> f x y@@ -1090,8 +1233,10 @@     def ">>" = Just $ bopDef $ sintOp P.AShr ++ uintOp P.LShr     def "<<" = Just $ bopDef $ intOp P.Shl     def ">>>" = Just $ bopDef $ sintOp P.LShr ++ uintOp P.LShr-    def "==" = Just $ fun2 $ \xs ys -> return $ ValuePrim $ BoolValue $ xs == ys-    def "!=" = Just $ fun2 $ \xs ys -> return $ ValuePrim $ BoolValue $ xs /= ys+    def "==" = Just $ fun2 $+               \xs ys -> return $ ValuePrim $ BoolValue $ xs == ys+    def "!=" = Just $ fun2 $+               \xs ys -> return $ ValuePrim $ BoolValue $ xs /= ys      -- The short-circuiting is handled directly in 'eval'; these cases     -- are only used when partially applying and such.@@ -1152,23 +1297,33 @@     def s | "reduce_stream" `isPrefixOf` s =               Just $ fun3t $ \_ f arg -> stream f arg -    def "map" = Just $ fun2t $ \f xs ->-      toArray =<< mapM (apply noLoc mempty f) (fromArray xs)+    def "map" = Just $ TermPoly Nothing $ \t -> return $ ValueFun $ \v ->+      case (fromTuple v, unfoldFunType t) of+        (Just [f, xs], ([_], ret_t))+          | Just rowshape <- typeRowShape ret_t ->+              toArray' rowshape <$> mapM (apply noLoc mempty f) (snd $ fromArray xs)+          | otherwise ->+              error $ "Bad return type: " ++ pretty ret_t+        _ ->+          error $ "Invalid arguments to map intrinsic:\n" +++          unlines [pretty t, pretty v]+      where typeRowShape = traverse id . structTypeShape mempty . stripArray 1      def s | "reduce" `isPrefixOf` s = Just $ fun3t $ \f ne xs ->-      foldM (apply2 noLoc mempty f) ne $ fromArray xs+      foldM (apply2 noLoc mempty f) ne $ snd $ fromArray xs      def "scan" = Just $ fun3t $ \f ne xs -> do       let next (out, acc) x = do             x' <- apply2 noLoc mempty f acc x             return (x':out, x')-      toArray . reverse . fst =<< foldM next ([], ne) (fromArray xs)+      toArray' (valueShape ne) . reverse . fst <$>+        foldM next ([], ne) (snd $ fromArray xs)      def "scatter" = Just $ fun3t $ \arr is vs ->       case arr of-        ValueArray arr' ->-          return $ ValueArray $ foldl' update arr'-          (zip (map asInt $ fromArray is) (fromArray vs))+        ValueArray shape arr' ->+          return $ ValueArray shape $ foldl' update arr' $+          zip (map asInt $ snd $ fromArray is) (snd $ fromArray vs)         _ ->           error $ "scatter expects array, but got: " ++ pretty arr       where update arr' (i, v) =@@ -1177,9 +1332,9 @@      def "hist" = Just $ fun6t $ \_ arr fun _ is vs ->       case arr of-        ValueArray arr' ->-          ValueArray <$> foldM (update fun) arr'-          (zip (map asInt $ fromArray is) (fromArray vs))+        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       where update fun arr' (i, v) =@@ -1189,16 +1344,19 @@                 return $ arr' // [(i, v')]               else return arr' -    def "partition" = Just $ fun3t $ \k f xs ->-      let next outs x = do+    def "partition" = Just $ fun3t $ \k f xs -> do+      let (ShapeDim _ rowshape, xs') = fromArray xs++          next outs x = do             i <- asInt <$> apply noLoc mempty f x             return $ insertAt i x outs           pack parts =-            toTuple [toArray' $ concat parts,-                     toArray' $+            toTuple [toArray' rowshape $ concat parts,+                     toArray' rowshape $                      map (ValuePrim . SignedValue . Int32Value . genericLength) parts]-      in pack . map reverse <$>-         foldM next (replicate (asInt k) []) (fromArray xs)++      pack . map reverse <$>+        foldM next (replicate (asInt k) []) xs'       where insertAt 0 x (l:ls) = (x:l):ls             insertAt i x (l:ls) = l:insertAt (i-1) x ls             insertAt _ _ ls = ls@@ -1206,36 +1364,50 @@     def "cmp_threshold" = Just $ fun2t $ \_ _ ->       return $ ValuePrim $ BoolValue True -    def "unzip" = Just $ fun1 $ \x ->-      toTuple <$> listPair (unzip $ map (fromPair . fromTuple) $ fromArray x)+    def "unzip" = Just $ fun1 $ \x -> do+      let ShapeDim _ (ShapeRecord fs) = valueShape x+          Just [xs_shape, ys_shape] = areTupleFields fs+          listPair (xs, ys) =+            [toArray' xs_shape xs, toArray' ys_shape ys]++      return $ toTuple $ listPair $ unzip $ map (fromPair . fromTuple) $ snd $ fromArray x       where fromPair (Just [x,y]) = (x,y)             fromPair l = error $ "Not a pair: " ++ pretty l-            listPair (xs, ys) = do-              xs' <- toArray xs-              ys' <- toArray ys-              return [xs', ys'] -    def "zip" = Just $ fun2t $ \xs ys ->-      toArray $ map toTuple $ transpose [fromArray xs, fromArray ys]+    def "zip" = Just $ fun2t $ \xs ys -> do+      let ShapeDim _ xs_rowshape = valueShape xs+          ShapeDim _ ys_rowshape = valueShape ys+      return $ toArray' (ShapeRecord (tupleFields [xs_rowshape, ys_rowshape])) $+        map toTuple $ transpose [snd $ fromArray xs, snd $ fromArray ys] -    def "concat" = Just $ fun2t $ \xs ys ->-      toArray $ fromArray xs ++ fromArray ys+    def "concat" = Just $ fun2t $ \xs ys -> do+      let (ShapeDim _ rowshape, xs') = fromArray xs+          (_, ys') = fromArray ys+      return $ toArray' rowshape $ xs' ++ ys' -    def "transpose" = Just $ fun1 $-      (toArray <=< mapM toArray) . transpose . map fromArray . fromArray+    def "transpose" = Just $ fun1 $ \xs -> do+      let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs+      return $ toArray (ShapeDim m (ShapeDim n shape)) $+        map (toArray (ShapeDim n shape)) $ transpose $ map (snd . fromArray) xs' -    def "rotate" = Just $ fun2t $ \i xs ->-      if asInt i > 0-      then let (bef, aft) = splitAt (asInt i) $ fromArray xs-           in toArray $ aft ++ bef-      else let (bef, aft) = splitFromEnd (-asInt i) $ fromArray xs-           in toArray $ aft ++ bef+    def "rotate" = Just $ fun2t $ \i xs -> do+      let (shape, xs') = fromArray xs+      return $+        if asInt i > 0+        then let (bef, aft) = splitAt (asInt i) xs'+             in toArray shape $ aft ++ bef+        else let (bef, aft) = splitFromEnd (-asInt i) xs'+             in toArray shape $ aft ++ bef -    def "flatten" = Just $ fun1 $-      toArray . concatMap fromArray . fromArray+    def "flatten" = Just $ fun1 $ \xs -> do+      let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs+      return $ toArray (ShapeDim (n*m) shape) $ concatMap (snd . fromArray) xs' -    def "unflatten" = Just $ fun3t $ \_ m xs ->-      toArray =<< mapM toArray (chunk (asInt m) $ fromArray xs)+    def "unflatten" = Just $ fun3t $ \n m xs -> do+      let (ShapeDim _ innershape, xs') = fromArray xs+          rowshape = ShapeDim (asInt32 m) innershape+          shape = ShapeDim (asInt32 n) rowshape+      return $ toArray shape $ map (toArray rowshape) $ chunk (asInt m) xs'      def "opaque" = Just $ fun1 return @@ -1253,7 +1425,7 @@       t <- nameFromString s `M.lookup` namesToPrimTypes       return $ T.TypeAbbr Unlifted [] $ Scalar $ Prim t -    stream f arg@(ValueArray xs) =+    stream f arg@(ValueArray _ xs) =       let n = ValuePrim $ SignedValue $ Int32Value $ arrayLength xs       in apply2 noLoc mempty f n arg     stream _ arg = error $ "Cannot stream: " ++ pretty arg@@ -1276,13 +1448,25 @@ -- horribly if these are ill-typed. interpretFunction :: Ctx -> VName -> [F.Value] -> Either String (F ExtOp Value) interpretFunction ctx fname vs = do+  ft <- case lookupVar (qualName fname) $ ctxEnv ctx of+          Just (TermValue (Just (T.BoundV _ t)) _) ->+            Right $ updateType (map valueType vs) t+          Just (TermPoly (Just (T.BoundV _ t)) _) ->+            Right $ updateType (map valueType vs) t+          _ ->+            Left $ "Unknown function `" <> prettyName fname <> "`."+   vs' <- case mapM convertValue vs of            Just vs' -> Right vs'            Nothing -> Left "Invalid input: irregular array."    Right $ runEvalM (ctxImports ctx) $ do-    f <- evalTermVar (ctxEnv ctx) (qualName fname)+    f <- evalTermVar (ctxEnv ctx) (qualName fname) ft     foldM (apply noLoc mempty) f vs' -  where convertValue (F.PrimValue p) = Just $ ValuePrim p-        convertValue (F.ArrayValue arr _) = mkArray =<< mapM convertValue (elems arr)+  where updateType (vt:vts) (Scalar (Arrow als u _ rt)) =+          Scalar $ Arrow als u (valueStructType vt) $ updateType vts rt+        updateType _ t = t++        convertValue (F.PrimValue p) = Just $ ValuePrim p+        convertValue (F.ArrayValue arr t) = mkArray t =<< mapM convertValue (elems arr)
src/Language/Futhark/Parser/Parser.y view
@@ -29,6 +29,7 @@ import Data.Char (ord) import Data.Maybe (fromMaybe, fromJust) import Data.Loc hiding (L) -- Lexer has replacements.+import Data.List (genericLength) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Monoid@@ -527,19 +528,19 @@ -- permit inside array indices operations (there is an ambiguity with -- array slices). Exp :: { UncheckedExp }-     : Exp ':' TypeExpDecl { Ascript $1 $3 NoInfo (srcspan $1 $>) }-     | Exp ':>' TypeExpDecl { Ascript $1 $3 NoInfo (srcspan $1 $>) }+     : Exp ':' TypeExpDecl { Ascript $1 $3 (srcspan $1 $>) }+     | Exp ':>' TypeExpDecl { Coerce $1 $3 (NoInfo,NoInfo) (srcspan $1 $>) }      | Exp2 %prec ':'      { $1 }  Exp2 :: { UncheckedExp }      : if Exp then Exp else Exp %prec ifprec-                      { If $2 $4 $6 NoInfo (srcspan $1 $>) }+                      { If $2 $4 $6 (NoInfo,NoInfo) (srcspan $1 $>) }       | loop Pattern LoopForm do Exp %prec ifprec-         {% fmap (\t -> DoLoop $2 t $3 $5 (srcspan $1 $>)) (patternExp $2) }+         {% fmap (\t -> DoLoop [] $2 t $3 $5 NoInfo (srcspan $1 $>)) (patternExp $2) }       | loop Pattern '=' Exp LoopForm do Exp %prec ifprec-         { DoLoop $2 $4 $5 $7 (srcspan $1 $>) }+         { DoLoop [] $2 $4 $5 $7 NoInfo (srcspan $1 $>) }       | LetExp %prec letprec { $1 } @@ -577,14 +578,14 @@      | Exp2 '<|...' Exp2   { binOp $1 $2 $3 }       | Exp2 '<' Exp2              { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 }-     | Exp2 '`' QualName '`' Exp2 { BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo (srcspan $1 $>) }+     | Exp2 '`' QualName '`' Exp2 { BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo NoInfo (srcspan $1 $>) } -     | Exp2 '...' Exp2           { Range $1 Nothing (ToInclusive $3) NoInfo (srcspan $1 $>) }-     | Exp2 '..<' Exp2           { Range $1 Nothing (UpToExclusive $3) NoInfo (srcspan $1 $>) }-     | Exp2 '..>' Exp2           { Range $1 Nothing (DownToExclusive $3) NoInfo (srcspan $1 $>) }-     | Exp2 '..' Exp2 '...' Exp2 { Range $1 (Just $3) (ToInclusive $5) NoInfo (srcspan $1 $>) }-     | Exp2 '..' Exp2 '..<' Exp2 { Range $1 (Just $3) (UpToExclusive $5) NoInfo (srcspan $1 $>) }-     | Exp2 '..' Exp2 '..>' Exp2 { Range $1 (Just $3) (DownToExclusive $5) NoInfo (srcspan $1 $>) }+     | Exp2 '...' Exp2           { Range $1 Nothing (ToInclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }+     | Exp2 '..<' Exp2           { Range $1 Nothing (UpToExclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }+     | Exp2 '..>' Exp2           { Range $1 Nothing (DownToExclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }+     | Exp2 '..' Exp2 '...' Exp2 { Range $1 (Just $3) (ToInclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }+     | Exp2 '..' Exp2 '..<' Exp2 { Range $1 (Just $3) (UpToExclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }+     | Exp2 '..' Exp2 '..>' Exp2 { Range $1 (Just $3) (DownToExclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }      | Exp2 '..' Atom            {% twoDotsRange $2 }      | Atom '..' Exp2            {% twoDotsRange $2 }      | '-' Exp2@@ -604,7 +605,7 @@ Apply_ :: { UncheckedExp }        : ApplyList { case $1 of                        ((Constr n [] _ loc1):_) -> Constr n (tail $1) NoInfo (srcspan loc1 (last $1))-                       _                -> foldl1 (\f x -> Apply f x NoInfo NoInfo (srcspan f x)) $1 }+                       _                -> foldl1 (\f x -> Apply f x NoInfo (NoInfo, NoInfo) (srcspan f x)) $1 }  ApplyList :: { [UncheckedExp] }           : ApplyList Atom %prec juxtprec@@ -625,9 +626,9 @@                         StringLit (encode s) loc }      | '(' Exp ')' FieldAccesses        { foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))-               (Parens $2 (srcspan $1 $3))+               (Parens $2 (srcspan $1 ($3:map snd $>)))                $4 }-     | '(' Exp ')[' DimIndices ']'    { Index (Parens $2 $1) $4 NoInfo (srcspan $1 $>) }+     | '(' Exp ')[' DimIndices ']'    { Index (Parens $2 $1) $4 (NoInfo, NoInfo) (srcspan $1 $>) }      | '(' Exp ',' Exps1 ')'          { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }      | '('      ')'                   { TupLit [] (srcspan $1 $>) }      | '[' Exps1 ']'                  { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }@@ -636,7 +637,7 @@      | QualVarSlice FieldAccesses        { let ((v, vloc),slice,loc) = $1          in foldl (\x (y, _) -> Project y x NoInfo (srcspan x (srclocOf x)))-                  (Index (Var v NoInfo vloc) slice NoInfo (srcspan vloc loc))+                  (Index (Var v NoInfo vloc) slice (NoInfo, NoInfo) (srcspan vloc loc))                   $2 }      | QualName        { Var (fst $1) NoInfo (snd $1) }@@ -651,12 +652,12 @@      | '(' '-' ')'         { OpSection (qualName (nameFromString "-")) NoInfo (srcspan $1 $>) }      | '(' Exp2 '-' ')'-        { OpSectionLeft (qualName (nameFromString "-"))-           NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }+       { OpSectionLeft (qualName (nameFromString "-"))+         NoInfo $2 (NoInfo, NoInfo) (NoInfo, NoInfo) (srcspan $1 $>) }      | '(' BinOp Exp2 ')'        { OpSectionRight (fst $2) NoInfo $3 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }      | '(' Exp2 BinOp ')'-       { OpSectionLeft (fst $3) NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }+       { OpSectionLeft (fst $3) NoInfo $2 (NoInfo, NoInfo) (NoInfo, NoInfo) (srcspan $1 $>) }      | '(' BinOp ')'        { OpSection (fst $2) NoInfo (srcspan $1 $>) } @@ -717,11 +718,12 @@  LetExp :: { UncheckedExp }      : let Pattern '=' Exp LetBody-                      { LetPat $2 $4 $5 NoInfo (srcspan $1 $>) }+                      { LetPat $2 $4 $5 (NoInfo, NoInfo) (srcspan $1 $>) }       | let id TypeParams FunParams1 maybeAscription(TypeExpDecl) '=' Exp LetBody        { let L _ (ID name) = $2-         in LetFun name ($3, fst $4 : snd $4, (fmap declaredType $5), NoInfo, $7) $8 (srcspan $1 $>) }+         in LetFun name ($3, fst $4 : snd $4, (fmap declaredType $5), NoInfo, $7)+            $8 NoInfo (srcspan $1 $>) }       | let VarSlice '=' Exp LetBody                       { let ((v,_),slice,loc) = $2; ident = Ident v NoInfo loc@@ -733,7 +735,7 @@  MatchExp :: { UncheckedExp }           : match Exp Cases  { let loc = srcspan $1 (NE.toList $>)-                               in Match $2 $> NoInfo loc  }+                               in Match $2 $> (NoInfo, NoInfo) loc  }  Cases :: { NE.NonEmpty (CaseBase NoInfo Name) }        : Case  %prec caseprec { $1 NE.:| [] }@@ -1071,7 +1073,7 @@ binOpName (L loc (SYMBOL _ qs op)) = (QualName qs op, loc)  binOp x (L loc (SYMBOL _ qs op)) y =-  BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) NoInfo $+  BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) NoInfo NoInfo $   srcspan x y  getTokens :: ParserMonad ([L Token], Pos)
+ src/Language/Futhark/Prelude.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- | The Futhark Prelude Library embedded embedded as strings read+-- during compilation of the Futhark compiler.  The advantage is that+-- the prelude can be accessed without reading it from disk, thus+-- saving users from include path headaches.+module Language.Futhark.Prelude (prelude) where++import Data.FileEmbed+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified System.FilePath.Posix as Posix++import Futhark.Util (toPOSIX)++-- | Prelude embedded as 'T.Text' values, one for every file.+prelude :: [(Posix.FilePath, T.Text)]+prelude = map fixup prelude_bs+  where prelude_bs = $(embedDir "prelude")+        fixup (path, s) = ("/prelude" Posix.</> toPOSIX path, T.decodeUtf8 s)
src/Language/Futhark/Pretty.hs view
@@ -118,6 +118,9 @@ instance Pretty (ShapeDecl Int32) where   ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (ShapeDecl Bool) where+  ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds)+ instance Pretty (ShapeDecl dim) => Pretty (ScalarTypeBase dim as) where   ppr = pprPrec 0   pprPrec _ (Prim et) = ppr et@@ -126,15 +129,16 @@     ppr u <> ppr (qualNameFromTypeName et) <+> spread (map (pprPrec 3) targs)   pprPrec _ (Record fs)     | Just ts <- areTupleFields fs =-        parens $ commasep $ map ppr ts+        oneLine (parens $ commasep $ map ppr ts)+        <|> parens (align $ mconcat $ punctuate (text "," <> line) $ map ppr ts)     | otherwise =         oneLine (braces $ commasep fs')-        <|> braces (mconcat $ punctuate (text "," <> line) fs')+        <|> braces (align $ mconcat $ punctuate (text "," <> line) fs')     where ppField (name, t) = text (nameToString name) <> colon <+> align (ppr t)           fs' = map ppField $ M.toList fs   pprPrec p (Arrow _ (Named v) t1 t2) =     parensIf (p > 1) $-    parens (pprName v <> colon <+> ppr t1) <+/> text "->" <+> pprPrec 1 t2+    parens (pprName v <> colon <+> align (ppr t1)) <+/> text "->" <+> pprPrec 1 t2   pprPrec p (Arrow _ Unnamed t1 t2) =     parensIf (p > 1) $ pprPrec 2 t1 <+/> text "->" <+> pprPrec 1 t2   pprPrec p (Sum cs) =@@ -146,7 +150,7 @@  instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where   ppr = pprPrec 0-  pprPrec _ (Array _ u at shape) = ppr u <> ppr shape <> pprPrec 1 at+  pprPrec _ (Array _ u at shape) = ppr u <> ppr shape <> align (pprPrec 1 at)   pprPrec p (Scalar t) = pprPrec p t  instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim) where@@ -208,11 +212,18 @@  instance (Eq vn, IsName vn, Annot f) => Pretty (ExpBase f vn) where   ppr = pprPrec (-1)-  pprPrec _ (Var name _ _) = ppr name+  pprPrec _ (Var name t _) = ppr name <> inst+    where inst = case unAnnot t of+                   Just t'+                     | isEnvVarSet "FUTHARK_COMPILER_DEBUGGING" False ->+                         text "@" <> parens (align $ ppr t')+                   _ -> mempty   pprPrec _ (Parens e _) = align $ parens $ ppr e   pprPrec _ (QualParens (v, _) e _) = ppr v <> text "." <> align (parens $ ppr e)-  pprPrec p (Ascript e t _ _) =-    parensIf (p /= -1) $ pprPrec 0 e <+> colon <+> pprPrec 0 t+  pprPrec p (Ascript e t _) =+    parensIf (p /= -1) $ pprPrec 0 e <+> text ":" <+> pprPrec 0 t+  pprPrec p (Coerce e t _ _) =+    parensIf (p /= -1) $ pprPrec 0 e <+> text ":>" <+> pprPrec 0 t   pprPrec _ (Literal v _) = ppr v   pprPrec _ (IntLit v _ _) = ppr v   pprPrec _ (FloatLit v _ _) = ppr v@@ -224,8 +235,13 @@     | otherwise                     = braces $ commasep $ map ppr fs     where fieldArray (RecordFieldExplicit _ e _) = hasArrayLit e           fieldArray RecordFieldImplicit{} = False-  pprPrec _ (ArrayLit es _ _) =-    brackets $ commasep $ map ppr es+  pprPrec _ (ArrayLit es info _) =+    brackets (commasep $ map ppr es) <> info'+    where info' = case unAnnot info of+                    Just t+                      | isEnvVarSet "FUTHARK_COMPILER_DEBUGGING" False ->+                          text "@" <> parens (align $ ppr t)+                    _ -> mempty   pprPrec _ (StringLit s _) =     text $ show $ decode s   pprPrec p (Range start maybe_step end _ _) =@@ -235,13 +251,13 @@       DownToExclusive end' -> text "..>" <> ppr end'       ToInclusive     end' -> text "..." <> ppr end'       UpToExclusive   end' -> text "..<" <> ppr end'-  pprPrec p (BinOp (bop, _) _ (x,_) (y,_) _ _) = prettyBinOp p bop x y+  pprPrec p (BinOp (bop,_) _ (x,_) (y,_) _ _ _) = prettyBinOp p bop x y   pprPrec _ (Project k e _ _) = ppr e <> text "." <> ppr k   pprPrec _ (If c t f _ _) = text "if" <+> ppr c </>                              text "then" <+> align (ppr t) </>                              text "else" <+> align (ppr f)   pprPrec p (Apply f arg _ _ _) =-    parensIf (p >= 10) $ ppr f <+> pprPrec 10 arg+    parensIf (p >= 10) $ pprPrec 0 f <+/> pprPrec 10 arg   pprPrec _ (Negate e _) = text "-" <> ppr e   pprPrec p (LetPat pat e body _ _) =     parensIf (p /= -1) $ align $@@ -258,7 +274,7 @@                         Match{}     -> True                         ArrayLit{}  -> False                         _           -> hasArrayLit e-  pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _) =+  pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _ _) =     text "let" <+> pprName fname <+> spread (map ppr tparams ++ map ppr params) <>     retdecl' <+> equals </> indent 2 (ppr e) </>     letBody body@@ -302,9 +318,10 @@     where p name = text "." <> ppr name   pprPrec _ (IndexSection idxs _ _) =     parens $ text "." <> brackets (commasep (map ppr idxs))-  pprPrec _ (DoLoop pat initexp form loopbody _) =-    text "loop" <+> ppr pat <+>-    equals <+> ppr initexp <+> ppr form <+> text "do" </>+  pprPrec _ (DoLoop sizeparams pat initexp form loopbody _ _) =+    text "loop" <+>+    align (spread (map (brackets . pprName) sizeparams) <+/>+           ppr pat <+> equals <+/> ppr initexp <+/> ppr form <+> text "do") </>     indent 2 (ppr loopbody)   pprPrec _ (Constr n cs _ _) = text "#" <> ppr n <+> sep (map ppr cs)   pprPrec _ (Match e cs _ _) = text "match" <+> ppr e </> (stack . map ppr) (NE.toList cs)@@ -385,11 +402,11 @@ instance (Eq vn, IsName vn, Annot f) => Pretty (ValBindBase f vn) where   ppr (ValBind entry name retdecl rettype tparams args body _ _) =     text fun <+> pprName name <+>-    spread (map ppr tparams ++ map ppr args) <> retdecl' <> text " =" </>+    align (sep (map ppr tparams ++ map ppr args)) <> retdecl' <> text " =" </>     indent 2 (ppr body)     where fun | isJust entry = "entry"               | otherwise    = "let"-          retdecl' = case (ppr <$> unAnnot rettype) `mplus` (ppr <$> retdecl) of+          retdecl' = case (ppr . fst <$> unAnnot rettype) `mplus` (ppr <$> retdecl) of                        Just rettype' -> text ":" <+> rettype'                        Nothing       -> mempty
src/Language/Futhark/Query.hs view
@@ -88,14 +88,14 @@               patternDefs pat             Lambda params _ _ _ _ ->               mconcat (map patternDefs params)-            LetFun name (tparams, params, _, Info ret, _) _ loc ->+            LetFun name (tparams, params, _, Info ret, _) _ _ loc ->               let name_t = foldFunType (map patternStructType params) ret               in M.singleton name (DefBound $ BoundTerm name_t (locOf loc)) <>                  mconcat (map typeParamDefs tparams) <>                  mconcat (map patternDefs params)             LetWith v _ _ _ _ _ _ ->               identDefs v-            DoLoop merge _ form _ _ ->+            DoLoop _ merge _ form _ _ _ ->               patternDefs merge <>               case form of                 For i _ -> identDefs i@@ -112,7 +112,7 @@   expDefs (valBindBody vbind)   where vbind_t =           foldFunType (map patternStructType (valBindParams vbind)) $-          unInfo $ valBindRetType vbind+          fst $ unInfo $ valBindRetType vbind  typeBindDefs :: TypeBind -> Defs typeBindDefs tbind =@@ -267,10 +267,13 @@   | a `contains` pos = Just $ RawAtName (qualName $ identName a) (locOf a)   | b `contains` pos = Just $ RawAtName (qualName $ identName b) (locOf b) -atPosInExp (DoLoop merge _ _ _ _) pos+atPosInExp (DoLoop _ merge _ _ _ _ _) pos   | merge `contains` pos = atPosInPattern merge pos -atPosInExp (Ascript _ tdecl _ _) pos+atPosInExp (Ascript _ tdecl _) pos+  | tdecl `contains` pos = atPosInTypeExp (declaredType tdecl) pos++atPosInExp (Coerce _ tdecl _ _) pos   | tdecl `contains` pos = atPosInTypeExp (declaredType tdecl) pos  atPosInExp e pos = do
src/Language/Futhark/Semantic.hs view
@@ -136,6 +136,11 @@   Env vt1 tt1 st1 mt1 nt1 <> Env vt2 tt2 st2 mt2 nt2 =     Env (vt1<>vt2) (tt1<>tt2) (st1<>st2) (mt1<>mt2) (nt1<>nt2) +instance Pretty Namespace where+  ppr Term = text "name"+  ppr Type = text "type"+  ppr Signature = text "module type"+ instance Monoid Env where   mempty = Env mempty mempty mempty mempty mempty
src/Language/Futhark/Syntax.hs view
@@ -111,12 +111,16 @@ -- | Convenience class for deriving 'Show' instances for the AST. class (Show vn,        Show (f VName),-       Show (f Diet),+       Show (f (Diet, Maybe VName)),        Show (f String),        Show (f [VName]),+       Show (f ([VName], [VName])),        Show (f PatternType),+       Show (f (PatternType, [VName])),+       Show (f (StructType, [VName])),        Show (f Int),        Show (f StructType),+       Show (f (StructType, Maybe VName)),        Show (f (Aliasing, StructType)),        Show (f (M.Map VName VName)),        Show (f Uniqueness)) => Showable f vn where@@ -227,6 +231,8 @@   traverse _ (ConstDim x) = pure $ ConstDim x   traverse _ AnyDim = pure AnyDim +-- Note that the notion of unifyDims here is intentionally not what we+-- use when we do real type unification in the type checker. instance ArrayDim (DimDecl VName) where   unifyDims AnyDim y = Just y   unifyDims x AnyDim = Just x@@ -621,22 +627,37 @@             -- ^ Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@.             -- Second arg is the row type of the rows of the array. -            | Range (ExpBase f vn) (Maybe (ExpBase f vn)) (Inclusiveness (ExpBase f vn)) (f PatternType) SrcLoc+            | Range (ExpBase f vn) (Maybe (ExpBase f vn)) (Inclusiveness (ExpBase f vn))+              (f PatternType, f [VName]) SrcLoc              | Var (QualName vn) (f PatternType) SrcLoc -            | Ascript (ExpBase f vn) (TypeDeclBase f vn) (f PatternType) SrcLoc+            | Ascript (ExpBase f vn) (TypeDeclBase f vn) SrcLoc             -- ^ Type ascription: @e : t@. -            | LetPat (PatternBase f vn) (ExpBase f vn) (ExpBase f vn) (f PatternType) SrcLoc+            | Coerce (ExpBase f vn) (TypeDeclBase f vn) (f PatternType, f [VName]) SrcLoc+            -- ^ Size coercion: @e :> t@. -            | LetFun vn ([TypeParamBase vn], [PatternBase f vn], Maybe (TypeExp vn), f StructType, ExpBase f vn)-              (ExpBase f vn) SrcLoc+            | LetPat (PatternBase f vn) (ExpBase f vn) (ExpBase f vn)+              (f PatternType, f [VName]) SrcLoc -            | If     (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) (f PatternType) SrcLoc+            | LetFun vn ([TypeParamBase vn],+                         [PatternBase f vn],+                         Maybe (TypeExp vn),+                         f StructType,+                         ExpBase f vn)+              (ExpBase f vn) (f PatternType) SrcLoc -            | Apply (ExpBase f vn) (ExpBase f vn) (f Diet) (f PatternType) SrcLoc+            | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) (f PatternType, f [VName]) SrcLoc +            | Apply (ExpBase f vn) (ExpBase f vn)+              (f (Diet, Maybe VName)) (f PatternType, f [VName]) SrcLoc+              -- ^ The @Maybe VName@ is a possible existential size+              -- that is instantiated by this argument..+              --+              -- The @[VName]@ are the existential sizes that come+              -- into being at this call site.+             | Negate (ExpBase f vn) SrcLoc               -- ^ Numeric negation (ugly special case; Haskell did it first). @@ -645,11 +666,11 @@              | OpSection (QualName vn) (f PatternType) SrcLoc               -- ^ @+@; first two types are operands, third is result.-            | OpSectionLeft (QualName vn) (f PatternType)-              (ExpBase f vn) (f StructType, f StructType) (f PatternType) SrcLoc+            | OpSectionLeft (QualName vn) (f PatternType) (ExpBase f vn)+              (f (StructType, Maybe VName), f StructType) (f PatternType, f [VName]) SrcLoc               -- ^ @2+@; first type is operand, second is result.-            | OpSectionRight (QualName vn) (f PatternType)-              (ExpBase f vn) (f StructType, f StructType) (f PatternType) SrcLoc+            | OpSectionRight (QualName vn) (f PatternType) (ExpBase f vn)+              (f StructType, f (StructType, Maybe VName)) (f PatternType) SrcLoc               -- ^ @+2@; first type is operand, second is result.             | ProjectSection [Name] (f PatternType) SrcLoc               -- ^ Field projection as a section: @(.x.y.z)@.@@ -657,15 +678,18 @@               -- ^ Array indexing as a section: @(.[i,j])@.              | DoLoop-              (PatternBase f vn) -- Merge variable pattern+              [VName] -- Size parameters.+              (PatternBase f vn) -- Merge variable pattern.               (ExpBase f vn) -- Initial values of merge variables.               (LoopFormBase f vn) -- Do or while loop.               (ExpBase f vn) -- Loop body.+              (f (PatternType, [VName])) -- Return type.               SrcLoc              | BinOp (QualName vn, SrcLoc) (f PatternType)-              (ExpBase f vn, f StructType) (ExpBase f vn, f StructType)-              (f PatternType) SrcLoc+              (ExpBase f vn, f (StructType, Maybe VName))+              (ExpBase f vn, f (StructType, Maybe VName))+              (f PatternType) (f [VName]) SrcLoc              | Project Name (ExpBase f vn) (f PatternType) SrcLoc @@ -674,7 +698,7 @@                       [DimIndexBase f vn] (ExpBase f vn)                       (ExpBase f vn) (f PatternType) SrcLoc -            | Index (ExpBase f vn) [DimIndexBase f vn] (f PatternType) SrcLoc+            | Index (ExpBase f vn) [DimIndexBase f vn] (f PatternType, f [VName]) SrcLoc              | Update (ExpBase f vn) [DimIndexBase f vn] (ExpBase f vn) SrcLoc @@ -694,7 +718,8 @@             | Constr Name [ExpBase f vn] (f PatternType) SrcLoc             -- ^ An n-ary value constructor. -            | Match (ExpBase f vn) (NE.NonEmpty (CaseBase f vn)) (f PatternType) SrcLoc+            | Match (ExpBase f vn) (NE.NonEmpty (CaseBase f vn))+              (f PatternType, f [VName]) SrcLoc             -- ^ A match expression. deriving instance Showable f vn => Show (ExpBase f vn) deriving instance Eq (ExpBase NoInfo VName)@@ -712,14 +737,15 @@   locOf (ArrayLit _ _ pos)             = locOf pos   locOf (StringLit _ loc)              = locOf loc   locOf (Range _ _ _ _ pos)            = locOf pos-  locOf (BinOp _ _ _ _ _ pos)          = locOf pos+  locOf (BinOp _ _ _ _ _ _ loc)        = locOf loc   locOf (If _ _ _ _ pos)               = locOf pos   locOf (Var _ _ loc)                  = locOf loc-  locOf (Ascript _ _ _ loc)            = locOf loc+  locOf (Ascript _ _ loc)              = locOf loc+  locOf (Coerce _ _ _ loc)             = locOf loc   locOf (Negate _ pos)                 = locOf pos-  locOf (Apply _ _ _ _ pos)            = locOf pos+  locOf (Apply _ _ _ _ loc)            = locOf loc   locOf (LetPat _ _ _ _ loc)           = locOf loc-  locOf (LetFun _ _ _ loc)             = locOf loc+  locOf (LetFun _ _ _ _ loc)           = locOf loc   locOf (LetWith _ _ _ _ _ _ loc)      = locOf loc   locOf (Index _ _ _ loc)              = locOf loc   locOf (Update _ _ _ pos)             = locOf pos@@ -730,7 +756,7 @@   locOf (OpSectionRight _ _ _ _ _ loc) = locOf loc   locOf (ProjectSection _ _ loc)       = locOf loc   locOf (IndexSection _ _ loc)         = locOf loc-  locOf (DoLoop _ _ _ _ pos)           = locOf pos+  locOf (DoLoop _ _ _ _ _ _ loc)       = locOf loc   locOf (Unsafe _ loc)                 = locOf loc   locOf (Assert _ _ _ loc)             = locOf loc   locOf (Constr _ _ _ loc)             = locOf loc@@ -806,7 +832,7 @@                                 -- that are no longer in scope.                                 , valBindName       :: vn                                 , valBindRetDecl    :: Maybe (TypeExp vn)-                                , valBindRetType    :: f StructType+                                , valBindRetType    :: f (StructType, [VName])                                 , valBindTypeParams :: [TypeParamBase vn]                                 , valBindParams     :: [PatternBase f vn]                                 , valBindBody       :: ExpBase f vn
src/Language/Futhark/Traversals.hs view
@@ -22,6 +22,8 @@ module Language.Futhark.Traversals   ( ASTMapper(..)   , ASTMappable(..)+  , identityMapper+  , bareExp   ) where  import qualified Data.Set                as S@@ -40,6 +42,15 @@   , mapOnPatternType :: PatternType -> m PatternType   } +-- | An 'ASTMapper' that just leaves its input unchanged.+identityMapper :: Monad m => ASTMapper m+identityMapper = ASTMapper { mapOnExp = return+                           , mapOnName = return+                           , mapOnQualName = return+                           , mapOnStructType = return+                           , mapOnPatternType = return+                           }+ class ASTMappable x where   -- | Map a monadic action across the immediate children of an   -- object.  Importantly, the 'astMap' action is not invoked for@@ -70,36 +81,40 @@     RecordLit <$> astMap tv fields <*> pure loc   astMap tv (ArrayLit els t loc) =     ArrayLit <$> mapM (mapOnExp tv) els <*> traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (Range start next end t loc) =+  astMap tv (Range start next end (t, ext) loc) =     Range <$> mapOnExp tv start <*> traverse (mapOnExp tv) next <*>-    traverse (mapOnExp tv) end <*> traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (Ascript e tdecl t loc) =-    Ascript <$> mapOnExp tv e <*> astMap tv tdecl <*>-    traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (BinOp (fname, fname_loc) t (x,xt) (y,yt) (Info rt) loc) =+    traverse (mapOnExp tv) end <*>+    ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc+  astMap tv (Ascript e tdecl loc) =+    Ascript <$> mapOnExp tv e <*> astMap tv tdecl <*> pure loc+  astMap tv (Coerce e tdecl (t, ext) loc) =+    Coerce <$> mapOnExp tv e <*> astMap tv tdecl <*>+    ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc+  astMap tv (BinOp (fname, fname_loc) t (x,Info(xt,xext)) (y,Info(yt,yext)) (Info rt) ext loc) =     BinOp <$> ((,) <$> mapOnQualName tv fname <*> pure fname_loc) <*>     traverse (mapOnPatternType tv) t <*>-    ((,) <$> mapOnExp tv x <*> traverse (mapOnStructType tv) xt) <*>-    ((,) <$> mapOnExp tv y <*> traverse (mapOnStructType tv) yt) <*>-    (Info <$> mapOnPatternType tv rt) <*> pure loc+    ((,) <$> mapOnExp tv x <*>+     (Info <$> ((,) <$> mapOnStructType tv xt <*> pure xext))) <*>+    ((,) <$> mapOnExp tv y <*>+     (Info <$> ((,) <$> mapOnStructType tv yt <*> pure yext))) <*>+    (Info <$> mapOnPatternType tv rt) <*> pure ext <*> pure loc   astMap tv (Negate x loc) =     Negate <$> mapOnExp tv x <*> pure loc-  astMap tv (If c texp fexp t loc) =+  astMap tv (If c texp fexp (t, ext) loc) =     If <$> mapOnExp tv c <*> mapOnExp tv texp <*> mapOnExp tv fexp <*>-    traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (Apply f arg d (Info t) loc) =-    Apply <$> mapOnExp tv f <*> mapOnExp tv arg <*>-    pure d <*> (Info <$> mapOnPatternType tv t) <*>-    pure loc-  astMap tv (LetPat pat e body t loc) =-    LetPat <$> astMap tv pat <*> mapOnExp tv e <*>-    mapOnExp tv body <*> traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (LetFun name (fparams, params, ret, t, e) body loc) =+    ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc+  astMap tv (Apply f arg d (Info t, ext) loc) =+    Apply <$> mapOnExp tv f <*> mapOnExp tv arg <*> pure d <*>+    ((,) <$> (Info <$> mapOnPatternType tv t) <*> pure ext) <*> pure loc+  astMap tv (LetPat pat e body (t, ext) loc) =+    LetPat <$> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body <*>+    ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc+  astMap tv (LetFun name (fparams, params, ret, t, e) body body_t loc) =     LetFun <$> mapOnName tv name <*>     ((,,,,) <$> mapM (astMap tv) fparams <*> mapM (astMap tv) params <*>      traverse (astMap tv) ret <*> traverse (mapOnStructType tv) t <*>      mapOnExp tv e) <*>-    mapOnExp tv body <*> pure loc+    mapOnExp tv body <*> traverse (mapOnPatternType tv) body_t <*> pure loc   astMap tv (LetWith dest src idxexps vexp body t loc) =     LetWith <$>     astMap tv dest <*> astMap tv src <*>@@ -113,49 +128,48 @@     mapOnExp tv v <*> (Info <$> mapOnPatternType tv t) <*> pure loc   astMap tv (Project field e t loc) =     Project field <$> mapOnExp tv e <*> traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (Index arr idxexps t loc) =-    Index <$>-    mapOnExp tv arr <*>-    mapM (astMap tv) idxexps <*>-    traverse (mapOnPatternType tv) t <*>-    pure loc+  astMap tv (Index arr idxexps (t, ext) loc) =+    Index <$> mapOnExp tv arr <*> mapM (astMap tv) idxexps <*>+    ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc   astMap tv (Unsafe e loc) =     Unsafe <$> mapOnExp tv e <*> pure loc   astMap tv (Assert e1 e2 desc loc) =     Assert <$> mapOnExp tv e1 <*> mapOnExp tv e2 <*> pure desc <*> pure loc   astMap tv (Lambda params body ret t loc) =     Lambda <$> mapM (astMap tv) params <*>-    astMap tv body <*> traverse (astMap tv) ret <*>+    mapOnExp tv body <*> traverse (astMap tv) ret <*>     traverse (traverse $ mapOnStructType tv) t <*> pure loc   astMap tv (OpSection name t loc) =     OpSection <$> mapOnQualName tv name <*>     traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (OpSectionLeft name t arg (t1a, t1b) t2 loc) =+  astMap tv (OpSectionLeft name t arg (Info (t1a, argext), t1b) (t2, retext) loc) =     OpSectionLeft <$> mapOnQualName tv name <*>     traverse (mapOnPatternType tv) t <*> mapOnExp tv arg <*>-    ((,) <$> traverse (mapOnStructType tv) t1a <*>-      traverse (mapOnStructType tv) t1b) <*>-    traverse (mapOnPatternType tv) t2 <*> pure loc-  astMap tv (OpSectionRight name t arg (t1a, t1b) t2 loc) =+    ((,) <$>+     (Info <$> ((,) <$> mapOnStructType tv t1a <*> pure argext)) <*>+     traverse (mapOnStructType tv) t1b) <*>+    ((,) <$> traverse (mapOnPatternType tv) t2 <*> pure retext) <*> pure loc+  astMap tv (OpSectionRight name t arg (t1a, Info (t1b,argext)) t2 loc) =     OpSectionRight <$> mapOnQualName tv name <*>     traverse (mapOnPatternType tv) t <*> mapOnExp tv arg <*>-    ((,) <$> traverse (mapOnStructType tv) t1a <*>-     traverse (mapOnStructType tv) t1b) <*>+    ((,) <$>+     traverse (mapOnStructType tv) t1a <*>+     (Info <$> ((,) <$> mapOnStructType tv t1b <*> pure argext))) <*>     traverse (mapOnPatternType tv) t2 <*> pure loc   astMap tv (ProjectSection fields t loc) =     ProjectSection fields <$> traverse (mapOnPatternType tv) t <*> pure loc   astMap tv (IndexSection idxs t loc) =     IndexSection <$> mapM (astMap tv) idxs <*>     traverse (mapOnPatternType tv) t <*> pure loc-  astMap tv (DoLoop mergepat mergeexp form loopbody loc) =-    DoLoop <$> astMap tv mergepat <*>-    mapOnExp tv mergeexp <*> astMap tv form <*>-    mapOnExp tv loopbody <*> pure loc+  astMap tv (DoLoop sparams mergepat mergeexp form loopbody (Info (ret, ext)) loc) =+    DoLoop <$> mapM (mapOnName tv) sparams <*> astMap tv mergepat <*>+    mapOnExp tv mergeexp <*> astMap tv form <*> mapOnExp tv loopbody <*>+    (Info <$> ((,) <$> mapOnPatternType tv ret <*> pure ext)) <*> pure loc   astMap tv (Constr name es ts loc) =     Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatternType tv) ts <*> pure loc-  astMap tv (Match e cases t loc) =+  astMap tv (Match e cases (t, ext) loc) =     Match <$> mapOnExp tv e <*> astMap tv cases-          <*> traverse (mapOnPatternType tv) t <*> pure loc+          <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc  instance ASTMappable (LoopFormBase Info VName) where   astMap tv (For i bound) = For <$> astMap tv i <*> astMap tv bound@@ -298,3 +312,106 @@  instance (ASTMappable a, ASTMappable b, ASTMappable c) => ASTMappable (a,b,c) where   astMap tv (x,y,z) = (,,) <$> astMap tv x <*> astMap tv y <*> astMap tv z++-- It would be lovely if the following code would be written in terms+-- of ASTMappable, but unfortunately it involves changing the Info+-- functor.  For simplicity, the general traversals do not support+-- that.  Sometimes a little duplication is better than an overly+-- complex abstraction.  The types ensure that this will be correct+-- anyway, so it's just tedious, and not actually fragile.++bareTypeDecl :: TypeDeclBase Info VName -> TypeDeclBase NoInfo VName+bareTypeDecl (TypeDecl te _) = TypeDecl te NoInfo++bareField :: FieldBase Info VName -> FieldBase NoInfo VName+bareField (RecordFieldExplicit name e loc) =+  RecordFieldExplicit name (bareExp e) loc+bareField (RecordFieldImplicit name _ loc) =+  RecordFieldImplicit name NoInfo loc++barePat :: PatternBase Info VName -> PatternBase NoInfo VName+barePat (TuplePattern ps loc) = TuplePattern (map barePat ps) loc+barePat (RecordPattern fs loc) = RecordPattern (map (fmap barePat) fs) loc+barePat (PatternParens p loc) = PatternParens (barePat p) loc+barePat (Id v _ loc) = Id v NoInfo loc+barePat (Wildcard _ loc) = Wildcard NoInfo loc+barePat (PatternAscription pat (TypeDecl t _) loc) =+  PatternAscription (barePat pat) (TypeDecl t NoInfo) loc+barePat (PatternLit e _ loc) = PatternLit (bareExp e) NoInfo loc+barePat (PatternConstr c _ ps loc) = PatternConstr c NoInfo (map barePat ps) loc++bareDimIndex :: DimIndexBase Info VName -> DimIndexBase NoInfo VName+bareDimIndex (DimFix e) =+  DimFix $ bareExp e+bareDimIndex (DimSlice x y z) =+  DimSlice (bareExp <$> x) (bareExp <$> y) (bareExp <$> z)++bareLoopForm :: LoopFormBase Info VName -> LoopFormBase NoInfo VName+bareLoopForm (For (Ident i _ loc) e) = For (Ident i NoInfo loc) (bareExp e)+bareLoopForm (ForIn pat e) = ForIn (barePat pat) (bareExp e)+bareLoopForm (While e) = While (bareExp e)++bareCase :: CaseBase Info VName -> CaseBase NoInfo VName+bareCase (CasePat pat e loc) = CasePat (barePat pat) (bareExp e) loc++-- | Remove all annotations from an expression, but retain the+-- name/scope information.+bareExp :: ExpBase Info VName -> ExpBase NoInfo VName+bareExp (Var name _ loc) = Var name NoInfo loc+bareExp (Literal v loc) = Literal v loc+bareExp (IntLit val _ loc) = IntLit val NoInfo loc+bareExp (FloatLit val _ loc) = FloatLit val NoInfo loc+bareExp (Parens e loc) = Parens (bareExp e) loc+bareExp (QualParens name e loc) = QualParens name (bareExp e) loc+bareExp (TupLit els loc) = TupLit (map bareExp els) loc+bareExp (StringLit vs loc) = StringLit vs loc+bareExp (RecordLit fields loc) = RecordLit (map bareField fields) loc+bareExp (ArrayLit els _ loc) = ArrayLit (map bareExp els) NoInfo loc+bareExp (Range start next end _ loc) =+  Range (bareExp start) (fmap bareExp next)+  (fmap bareExp end) (NoInfo, NoInfo) loc+bareExp (Ascript e tdecl loc) =+  Ascript (bareExp e) (bareTypeDecl tdecl) loc+bareExp (Coerce e tdecl _ loc) =+  Coerce (bareExp e) (bareTypeDecl tdecl) (NoInfo, NoInfo) loc+bareExp (BinOp fname _ (x,_) (y,_) _ _ loc) =+  BinOp fname NoInfo (bareExp x, NoInfo) (bareExp y, NoInfo) NoInfo NoInfo loc+bareExp (Negate x loc) = Negate (bareExp x) loc+bareExp (If c texp fexp _ loc) =+  If (bareExp c) (bareExp texp) (bareExp fexp) (NoInfo, NoInfo) loc+bareExp (Apply f arg _ _ loc) =+  Apply (bareExp f) (bareExp arg) NoInfo (NoInfo, NoInfo) loc+bareExp (LetPat pat e body _ loc) =+  LetPat (barePat pat) (bareExp e) (bareExp body) (NoInfo, NoInfo) loc+bareExp (LetFun name (fparams, params, ret, _, e) body _ loc) =+  LetFun name (fparams, map barePat params, ret, NoInfo, bareExp e) (bareExp body) NoInfo loc+bareExp (LetWith (Ident dest _ destloc) (Ident src _ srcloc) idxexps vexp body _ loc) =+  LetWith (Ident dest NoInfo destloc) (Ident src NoInfo srcloc)+  (map bareDimIndex idxexps) (bareExp vexp)+  (bareExp body) NoInfo loc+bareExp (Update src slice v loc) =+  Update (bareExp src) (map bareDimIndex slice) (bareExp v) loc+bareExp (RecordUpdate src fs v _ loc) =+  RecordUpdate (bareExp src) fs (bareExp v) NoInfo loc+bareExp (Project field e _ loc) = Project field (bareExp e) NoInfo loc+bareExp (Index arr slice _ loc) =+  Index (bareExp arr) (map bareDimIndex slice) (NoInfo, NoInfo) loc+bareExp (Unsafe e loc) = Unsafe (bareExp e) loc+bareExp (Assert e1 e2 _ loc) = Assert (bareExp e1) (bareExp e2) NoInfo loc+bareExp (Lambda params body ret _ loc) =+  Lambda (map barePat params) (bareExp body) ret NoInfo loc+bareExp (OpSection name _ loc) = OpSection name NoInfo loc+bareExp (OpSectionLeft name _ arg _ _ loc) =+  OpSectionLeft name NoInfo (bareExp arg) (NoInfo, NoInfo) (NoInfo, NoInfo) loc+bareExp (OpSectionRight name _ arg _ _ loc) =+  OpSectionRight name NoInfo (bareExp arg) (NoInfo, NoInfo) NoInfo loc+bareExp (ProjectSection fields _ loc) = ProjectSection fields NoInfo loc+bareExp (IndexSection slice _ loc) =+  IndexSection (map bareDimIndex slice) NoInfo loc+bareExp (DoLoop _ mergepat mergeexp form loopbody _ loc) =+  DoLoop [] (barePat mergepat) (bareExp mergeexp) (bareLoopForm form)+  (bareExp loopbody) NoInfo loc+bareExp (Constr name es _ loc) =+  Constr name (map bareExp es) NoInfo loc+bareExp (Match e cases _ loc) =+  Match (bareExp e) (fmap bareCase cases) (NoInfo,NoInfo) loc
src/Language/Futhark/TypeChecker.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} -- | The type checker checks whether the program is type-consistent -- and adds type annotations and various other elaborations.  The -- program does not need to have any particular properties for the@@ -23,6 +24,7 @@ import Data.Either import Data.Ord import qualified Data.Map.Strict as M+import qualified Data.Set as S  import Prelude hiding (abs, mod) @@ -33,6 +35,7 @@ import Language.Futhark.TypeChecker.Modules import Language.Futhark.TypeChecker.Terms import Language.Futhark.TypeChecker.Types+import Futhark.Util.Pretty hiding (space)  --- The main checker @@ -126,10 +129,10 @@  dupDefinitionError :: MonadTypeChecker m =>                       Namespace -> Name -> SrcLoc -> SrcLoc -> m a-dupDefinitionError space name pos1 pos2 =-  throwError $ TypeError pos1 $-  "Duplicate definition of " ++ ppSpace space ++ " " ++-  nameToString name ++ ".  Previously defined at " ++ locStr pos2+dupDefinitionError space name loc1 loc2 =+  typeError loc1 mempty $+  "Duplicate definition of" <+> ppr space <+>+  pprName name <> ".  Previously defined at" <+> text (locStr loc2) <> "."  checkForDuplicateDecs :: [DecBase NoInfo Name] -> TypeM () checkForDuplicateDecs =@@ -188,14 +191,19 @@     name' <- checkName Term name loc     (tparams', vtype') <-       checkTypeParams tparams $ \tparams' -> bindingTypeParams tparams' $ do-        (vtype', _) <- checkTypeDecl tparams' vtype+        (vtype', _) <- checkTypeDecl vtype         return (tparams', vtype')      when (emptyDimParam $ unInfo $ expandedType vtype') $-      throwError $ TypeError loc $-      "All function parameters must have non-anonymous sizes.\n" ++-      "Hint: add size parameters to " ++ quote (prettyName name') ++ "."+      typeError loc mempty $+      "All function parameters must have non-anonymous sizes." </>+      "Hint: add size parameters to" <+> pquote (pprName name') <> "." +    let (params, _) = unfoldFunType $ unInfo $ expandedType vtype'+    when (null params && any isSizeParam tparams) $+      typeError loc mempty+      "Size parameters are only allowed on bindings that also have value parameters."+     let binding = BoundV tparams' $ unInfo $ expandedType vtype'         valenv =           mempty { envVtable = M.singleton name' binding@@ -273,7 +281,7 @@ checkSigExp (SigWith s (TypeRef tname ps td trloc) loc) = do   (s_abs, s_env, s') <- checkSigExpToEnv s   checkTypeParams ps $ \ps' -> do-    (td', _) <- bindingTypeParams ps' $ checkTypeDecl ps' td+    (td', _) <- bindingTypeParams ps' $ checkTypeDecl td     (tname', s_abs', s_env') <- refineEnv loc s_abs s_env tname ps' $ unInfo $ expandedType td'     return (MTy s_abs' $ ModEnv s_env', SigWith s' (TypeRef tname' ps' td' trloc) loc) checkSigExp (SigArrow maybe_pname e1 e2 loc) = do@@ -322,7 +330,7 @@   (v', env) <- lookupMod loc v   when (baseName (qualLeaf v') == nameFromString "intrinsics" &&         baseTag (qualLeaf v') <= maxIntrinsicTag) $-    throwError $ TypeError loc "The 'intrinsics' module may not be used in module expressions."+    typeError loc mempty "The 'intrinsics' module may not be used in module expressions."   return (MTy mempty env, ModVar v' loc) checkOneModExp (ModImport name NoInfo loc) = do   (name', env) <- lookupImport loc name@@ -336,7 +344,7 @@       (mty, psubsts, rsubsts) <- applyFunctor loc functor e_mty       return (mty, ModApply f' e' (Info psubsts) (Info rsubsts) loc)     _ ->-      throwError $ TypeError loc "Cannot apply non-parametric module."+      typeError loc mempty "Cannot apply non-parametric module." checkOneModExp (ModAscript me se NoInfo loc) = do   (me_mod, me') <- checkOneModExp me   (se_mty, se') <- checkSigExp se@@ -446,26 +454,32 @@               -> TypeM (Env, TypeBindBase Info VName) checkTypeBind (TypeBind name l tps td doc loc) =   checkTypeParams tps $ \tps' -> do-    (td', l') <- bindingTypeParams tps' $ checkTypeDecl tps' td+    (td', l') <- bindingTypeParams tps' $ checkTypeDecl td +    let used_dims = typeDimNames $ unInfo $ expandedType td'+    case filter ((`S.notMember` used_dims) . typeParamName) $+         filter isSizeParam tps' of+      [] -> return ()+      tp:_ -> typeError loc mempty $+              "Size parameter" <+> pquote (ppr tp) <+> "unused."+     case (l, l') of       (_, Lifted)         | l < Lifted ->-          throwError $ TypeError loc $-          "Non-lifted type abbreviations may not contain functions.\n" +++          typeError loc mempty $+          "Non-lifted type abbreviations may not contain functions." </>           "Hint: consider using 'type^'."       (_, SizeLifted)         | l < SizeLifted ->-          throwError $ TypeError loc $-          "Non-size-lifted type abbreviations may not contain size-lifted types.\n" +++          typeError loc mempty $+          "Non-size-lifted type abbreviations may not contain size-lifted types." </>           "Hint: consider using 'type~'."       (Unlifted, _)         | emptyDimParam $ unInfo $ expandedType td' ->-            warn loc $-            "Non-lifted type abbreviations may not use anonymous sizes in their definition.\n" ++-            "This will become an error in a future version of the compiler!\n" ++-            "Hint: use 'type~' or add size parameters to " ++-            quote (prettyName name) ++ "."+            typeError loc mempty $+            "Non-lifted type abbreviations may not use anonymous sizes in their definition." </>+            "Hint: use 'type~' or add size parameters to" <+>+            pquote (pprName name) <> "."       _ -> return ()      bindSpaced [(Type, name)] $ do@@ -479,7 +493,7 @@  checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind) checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc loc) = do-  (fname', tparams', params', maybe_tdecl', rettype, body') <-+  (fname', tparams', params', maybe_tdecl', rettype, retext, body') <-     checkFunDef (fname, maybe_tdecl, tparams, params, body, loc)    let (rettype_params, rettype') = unfoldFunType rettype@@ -488,20 +502,29 @@   case entry' of     Just _       | any isTypeParam tparams' ->-          throwError $ TypeError loc "Entry point functions may not be polymorphic."+          typeError loc mempty "Entry point functions may not be polymorphic." -      | any (not . patternOrderZero) params'-        || any (not . orderZero) rettype_params+      | not (all patternOrderZero params')+        || not (all orderZero rettype_params)         || not (orderZero rettype') ->-          throwError $ TypeError loc "Entry point functions may not be higher-order."+          typeError loc mempty "Entry point functions may not be higher-order." +      | sizes_only_in_ret <-+          S.fromList (map typeParamName tparams') `S.intersection`+          typeDimNames rettype' `S.difference`+          foldMap typeDimNames (map patternStructType params' ++ rettype_params),+        not $ S.null sizes_only_in_ret ->+          typeError loc mempty "Entry point functions must not be size-polymorphic in their return type."+       | p : _ <- filter nastyParameter params' ->-          warn loc $ "Entry point parameter\n\n  " <>-          pretty p <> "\n\nwill have an opaque type, so the entry point will likely not be callable."+          warn loc $ pretty $ "Entry point parameter\n" </>+          indent 2 (ppr p) </>+          "\nwill have an opaque type, so the entry point will likely not be callable."        | nastyReturnType maybe_tdecl' rettype ->-          warn loc $ "Entry point return type\n\n  " <>-          pretty rettype <> "\n\nwill have an opaque type, so the result will likely not be usable."+          warn loc $ pretty $ "Entry point return type\n" </>+          indent 2 (ppr rettype) </>+          "\nwill have an opaque type, so the result will likely not be usable."      _ -> return () @@ -512,7 +535,7 @@                  , envNameMap =                      M.singleton (Term, fname) $ qualName fname'                  },-           ValBind entry' fname' maybe_tdecl' (Info rettype) tparams' params' body' doc loc)+           ValBind entry' fname' maybe_tdecl' (Info (rettype, retext)) tparams' params' body' doc loc)  nastyType :: Monoid als => TypeBase dim als -> Bool nastyType (Scalar Prim{}) = False@@ -568,8 +591,8 @@  checkOneDec (ImportDec name NoInfo loc) = do   (name', env) <- lookupImport loc name-  when ("/futlib" `isPrefixOf` name) $-    warn loc $ name ++ " is already implicitly imported."+  when ("/prelude" `isPrefixOf` name) $+    typeError loc mempty $ ppr name <+> "may not be explicitly imported."   return (mempty, env, ImportDec name (Info name') loc)  checkOneDec (ValDec vb) = do
src/Language/Futhark/TypeChecker/Modules.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Futhark.TypeChecker.Modules   ( matchMTys   , newNamesForMTy@@ -181,13 +182,12 @@                               TypeSub $ TypeAbbr l cur_ps t),                               (v, TypeSub $ TypeAbbr l ps t)])                 env)-      else throwError $ TypeError loc $ "Cannot refine a type having " <>+      else typeError loc mempty $ "Cannot refine a type having" <+>            tpMsg ps <> " with a type having " <> tpMsg cur_ps <> "."   | otherwise =-      throwError $ TypeError loc $-      pretty tname ++ " is not an abstract type in the module type."+      typeError loc mempty $ ppr tname <+> "is not an abstract type in the module type."   where tpMsg [] = "no type parameters"-        tpMsg xs = "type parameters " <> unwords (map pretty xs)+        tpMsg xs = "type parameters" <+> spread (map ppr xs)  paramsMatch :: [TypeParam] -> [TypeParam] -> Bool paramsMatch ps1 ps2 = length ps1 == length ps2 && all match (zip ps1 ps2)@@ -222,7 +222,11 @@     case findTypeDef (fmap baseName name) mod of       Just (name', TypeAbbr mod_l ps t)         | mod_l > name_l ->-            mismatchedLiftedness name_l (map qualLeaf $ M.keys mod_abs)+            mismatchedLiftedness name_l+            (map qualLeaf $ M.keys mod_abs) (qualLeaf name) (mod_l, ps, t)+        | name_l < SizeLifted,+          emptyDims t ->+            anonymousSizes (map qualLeaf $ M.keys mod_abs)             (qualLeaf name) (mod_l, ps, t)         | Just (abs_name, _) <- M.lookup (fmap baseName name) abs_mapping ->             return (qualLeaf name, (abs_name, TypeAbbr name_l ps t))@@ -231,14 +235,25 @@       _ ->         missingType loc $ fmap baseName name   where mismatchedLiftedness name_l abs name mod_t =-          Left $ TypeError loc $-          unlines ["Module defines",-                   sindent $ ppTypeAbbr abs name mod_t,-                   "but module type requires " ++ what ++ "."]+          Left $ TypeError loc mempty $+          "Module defines" </>+          indent 2 (ppTypeAbbr abs name mod_t) </>+          "but module type requires" <+> text what <> "."           where what = case name_l of Unlifted -> "a non-lifted type"                                       SizeLifted -> "a size-lifted type"                                       Lifted -> "a lifted type" +        anonymousSizes abs name mod_t =+          Left $ TypeError loc mempty $+          "Module defines" </>+          indent 2 (ppTypeAbbr abs name mod_t) </>+          "which contains anonymous sizes, but module type requires non-lifted type."++        emptyDims :: StructType -> Bool+        emptyDims = isNothing . traverseDims onDim+          where onDim PosImmediate AnyDim = Nothing+                onDim _ d = Just d+ resolveMTyNames :: MTy -> MTy                 -> M.Map VName (QualName VName) resolveMTyNames = resolveMTyNames'@@ -260,7 +275,7 @@                   Just (QualName _ modname')                     | Just sig_env_mod <-                         M.lookup modname' $ envModTable mod_env ->-                      resolveModNames mod_env_mod sig_env_mod+                      resolveModNames sig_env_mod mod_env_mod                   _ -> mempty           in mconcat [ resolve Term mod_env $ envVtable sig_env                      , resolve Type mod_env $ envVtable sig_env@@ -275,18 +290,18 @@  missingType :: Pretty a => SrcLoc -> a -> Either TypeError b missingType loc name =-  Left $ TypeError loc $-  "Module does not define a type named " ++ pretty name ++ "."+  Left $ TypeError loc mempty $+  "Module does not define a type named" <+> ppr name <> "."  missingVal :: Pretty a => SrcLoc -> a -> Either TypeError b missingVal loc name =-  Left $ TypeError loc $-  "Module does not define a value named " ++ pretty name ++ "."+  Left $ TypeError loc mempty $+  "Module does not define a value named" <+> ppr name <> "."  missingMod :: Pretty a => SrcLoc -> a -> Either TypeError b missingMod loc name =-  Left $ TypeError loc $-  "Module does not define a module named " ++ pretty name ++ "."+  Left $ TypeError loc mempty $+  "Module does not define a module named" <+> ppr name <> "."  mismatchedType :: SrcLoc                -> [VName]@@ -295,23 +310,20 @@                -> (Liftedness, [TypeParam], StructType)                -> Either TypeError b mismatchedType loc abs name spec_t env_t =-  Left $ TypeError loc $-  unlines ["Module defines",-           sindent $ ppTypeAbbr abs name env_t,-           "but module type requires",-           sindent $ ppTypeAbbr abs name spec_t]--sindent :: String -> String-sindent = intercalate "\n" . map ("  "++) . lines+  Left $ TypeError loc mempty $+  "Module defines" </>+  indent 2 (ppTypeAbbr abs name env_t) </>+  "but module type requires" </>+  indent 2 (ppTypeAbbr abs name spec_t) -ppTypeAbbr :: [VName] -> VName -> (Liftedness, [TypeParam], StructType) -> String+ppTypeAbbr :: [VName] -> VName -> (Liftedness, [TypeParam], StructType) -> Doc ppTypeAbbr abs name (l, ps, Scalar (TypeVar () _ tn args))   | typeLeaf tn `elem` abs,     map typeParamToArg ps == args =-      pretty $ text "type" <> ppr l <+> pprName name <+>+      "type" <> ppr l <+> pprName name <+>       spread (map ppr ps) ppTypeAbbr _ name (l, ps, t) =-  pretty $ text "type" <> ppr l <+> pprName name <+>+  "type" <> ppr l <+> pprName name <+>   spread (map ppr ps) <+> equals <+/>   nest 2 (align (ppr t)) @@ -330,10 +342,12 @@                -> Either TypeError (M.Map VName VName)      matchMTys' _ (MTy _ ModFun{}) (MTy _ ModEnv{}) loc =-      Left $ TypeError loc "Cannot match parametric module with non-parametric module type."+      Left $ TypeError loc mempty+      "Cannot match parametric module with non-parametric module type."      matchMTys' _ (MTy _ ModEnv{}) (MTy _ ModFun{}) loc =-      Left $ TypeError loc "Cannot match non-parametric module with paramatric module type."+      Left $ TypeError loc mempty+      "Cannot match non-parametric module with paramatric module type."      matchMTys' old_abs_subst_to_type (MTy mod_abs mod) (MTy sig_abs sig) loc = do       -- Check that abstract types in 'sig' have an implementation in@@ -350,9 +364,11 @@     matchMods :: TypeSubs -> Mod -> Mod -> SrcLoc               -> Either TypeError (M.Map VName VName)     matchMods _ ModEnv{} ModFun{} loc =-      Left $ TypeError loc "Cannot match non-parametric module with parametric module type."+      Left $ TypeError loc mempty+      "Cannot match non-parametric module with parametric module type."     matchMods _ ModFun{} ModEnv{} loc =-      Left $ TypeError loc "Cannot match parametric module with non-parametric module type."+      Left $ TypeError loc mempty+      "Cannot match parametric module with non-parametric module type."      matchMods abs_subst_to_type (ModEnv mod) (ModEnv sig) loc =       matchEnvs abs_subst_to_type mod sig loc@@ -414,6 +430,15 @@       -- We have to create substitutions for the type parameters, too.       unless (length spec_ps == length ps) $ nomatch spec_t       param_substs <- mconcat <$> zipWithM matchTypeParam spec_ps ps++      case S.toList (mustBeExplicitInType t) `intersect` map typeParamName ps of+        [] -> return ()+        d:_ -> Left $ TypeError loc mempty $+               "Type" </>+               indent 2 (ppTypeAbbr [] name (l, ps, t)) </>+               textwrap "cannot be made abstract because size parameter" <+/> pquote (pprName d) <+/>+               textwrap "is not used as an array size in the definition."+       let spec_t' = substituteTypes (param_substs<>abs_subst_to_type) spec_t       if spec_t' == t         then return (spec_name, name)@@ -440,24 +465,26 @@       case matchValBinding loc spec_v v of         Nothing -> return (spec_name, name)         Just problem ->-          Left $ TypeError loc $ pretty $-          text "Module type specifies" </>+          Left $ TypeError loc mempty $+          "Module type specifies" </>           indent 2 (ppValBind spec_name spec_v) </>-          text "but module provides" </>+          "but module provides" </>           indent 2 (ppValBind spec_name v) </>-          maybe mempty text problem+          fromMaybe mempty problem -    matchValBinding :: SrcLoc -> BoundV -> BoundV -> Maybe (Maybe String)+    matchValBinding :: SrcLoc -> BoundV -> BoundV -> Maybe (Maybe Doc)     matchValBinding loc (BoundV _ orig_spec_t) (BoundV tps orig_t) =-      case doUnification loc tps (removeShapeAnnotations orig_spec_t) (removeShapeAnnotations orig_t) of-        Left (TypeError _ err) -> Just $ Just err+      case doUnification loc tps (toStruct orig_spec_t) (toStruct orig_t) of+        Left (TypeError _ notes msg) ->+          Just $ Just $ msg <> ppr notes         -- Even if they unify, we still have to verify the uniqueness         -- properties.-        Right t | t `subtypeOf` removeShapeAnnotations orig_spec_t -> Nothing+        Right t | noSizes t `subtypeOf`+                  noSizes orig_spec_t -> Nothing                 | otherwise -> Just Nothing      ppValBind v (BoundV tps t) =-      text "val" <+> pprName v <+> spread (map ppr tps) <+> colon </>+      "val" <+> pprName v <+> spread (map ppr tps) <+> colon </>       indent 2 (align (ppr t))  applyFunctor :: SrcLoc -> FunSig -> MTy
src/Language/Futhark/TypeChecker/Monad.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-} -- | Main monad in which the type checker runs, as well as ancillary -- data definitions. module Language.Futhark.TypeChecker.Monad@@ -20,10 +23,8 @@   , unknownVariableError   , underscoreUse   , functionIsNotValue--  , BreadCrumb(..)-  , MonadBreadCrumbs(..)-  , typeError+  , Notes+  , aNote    , MonadTypeChecker(..)   , checkName@@ -51,7 +52,6 @@   , Namespace(..)   , intrinsicsNameMap   , topLevelNameMap-  , ppSpace   ) where @@ -76,53 +76,68 @@ import Language.Futhark.Warnings import Futhark.FreshNames hiding (newName) import qualified Futhark.FreshNames+import Futhark.Util.Pretty hiding (space) --- | Information about an error during type checking.  The 'Show'--- instance for this type produces a human-readable description.-data TypeError = TypeError SrcLoc String+-- | A note with extra information regarding a type error.+newtype Note = Note Doc -unexpectedType :: MonadTypeChecker m => SrcLoc -> TypeBase () () -> [TypeBase () ()] -> m a+newtype Notes = Notes [Note]+  deriving (Semigroup, Monoid)++instance Pretty Note where+  ppr (Note msg) = "Note:" <+> align msg++instance Pretty Notes where+  ppr (Notes notes) = foldMap (((line<>line)<>) . ppr) notes++aNote :: Pretty a => a -> Notes+aNote = Notes . pure . Note . ppr++-- | Information about an error during type checking.+data TypeError = TypeError SrcLoc Notes Doc++instance Pretty TypeError where+  ppr (TypeError loc notes msg) =+    "Error at" <+> text (locStr loc) <+> ":" </>+    msg <> ppr notes++unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a unexpectedType loc _ [] =-  throwError $ TypeError loc $-  "Type of expression at " ++ locStr loc +++  typeError loc mempty $+  "Type of expression at" <+> text (locStr loc) <+>   "cannot have any type - possibly a bug in the type checker." unexpectedType loc t ts =-  throwError $ TypeError loc $-  "Type of expression at " ++ locStr loc ++ " must be one of " ++-  intercalate ", " (map pretty ts) ++ ", but is " ++-  pretty t ++ "."+  typeError loc mempty $+  "Type of expression at" <+> text (locStr loc) <+> "must be one of" <+>+  commasep (map ppr ts) <> ", but is" <+>+  ppr t <> "."  undefinedType :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a undefinedType loc name =-  throwError $ TypeError loc $-  "Unknown type " ++ pretty name ++ "."+  typeError loc mempty $ "Unknown type" <+> ppr name <> "."  functionIsNotValue :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a functionIsNotValue loc name =-  throwError $ TypeError loc $-  "Attempt to use function " ++ pretty name ++ " as value at " ++ locStr loc ++ "."+  typeError loc mempty $+  "Attempt to use function" <+> ppr name <+> "as value at" <+>+  text (locStr loc) <> "."  unappliedFunctor :: MonadTypeChecker m => SrcLoc -> m a unappliedFunctor loc =-  throwError $ TypeError loc "Cannot have parametric module here."+  typeError loc mempty "Cannot have parametric module here."  unknownVariableError :: MonadTypeChecker m =>                         Namespace -> QualName Name -> SrcLoc -> m a unknownVariableError space name loc =-  throwError $ TypeError loc $-  "Unknown " ++ ppSpace space ++ " " ++ quote (pretty name)+  typeError loc mempty $+  "Unknown" <+> ppr space <+> pquote (ppr name)  underscoreUse :: MonadTypeChecker m =>                  SrcLoc -> QualName Name -> m a underscoreUse loc name =-  throwError $ TypeError loc $-  "Use of " ++ quote (pretty name) +++  typeError loc mempty $ "Use of" <+> pquote (ppr name) <>   ": variables prefixed with underscore may not be accessed." -instance Show TypeError where-  show (TypeError pos msg) =-    "Error at " ++ locStr pos ++ ":\n" ++ msg- type ImportTable = M.Map String Env  data Context = Context { contextEnv :: Env@@ -132,7 +147,7 @@  -- | The type checker runs in this monad. newtype TypeM a = TypeM (RWST-                         Context -- Reader+                         Context            -- Reader                          Warnings           -- Writer                          VNameSource        -- State                          (Except TypeError) -- Inner monad@@ -169,9 +184,9 @@   my_path <- asks contextImportName   let canonical_import = includeToString $ mkImportFrom my_path file loc   case M.lookup canonical_import imports of-    Nothing    -> throwError $ TypeError loc $-                  unlines ["Unknown import \"" ++ canonical_import ++ "\"",-                           "Known: " ++ intercalate ", " (M.keys imports)]+    Nothing    -> typeError loc mempty $+                  "Unknown import" <+> dquotes (text canonical_import) </>+                  "Known:" <+> commasep (map text (M.keys imports))     Just scope -> return (canonical_import, scope)  localEnv :: Env -> TypeM a -> TypeM a@@ -179,37 +194,7 @@   let env' = env <> contextEnv ctx   in ctx { contextEnv = env' } --- | A piece of information that describes what process the type--- checker currently performing.  This is used to give better error--- messages.-data BreadCrumb = MatchingTypes (TypeBase () ()) (TypeBase () ())-                | MatchingFields Name--instance Show BreadCrumb where-  show (MatchingTypes t1 t2) =-    "When matching type\n" ++ indent (pretty t1) ++-    "\nwith\n" ++ indent (pretty t2)-    where indent = intercalate "\n" . map ("  "++) . lines-  show (MatchingFields field) =-    "When matching types of record field " ++ quote (pretty field) ++ "."---- | Tracking breadcrumbs to give a kind of "stack trace" in errors.-class Monad m => MonadBreadCrumbs m where-  breadCrumb :: BreadCrumb -> m a -> m a-  breadCrumb _ m = m--  getBreadCrumbs :: m [BreadCrumb]-  getBreadCrumbs = return []--typeError :: (Located loc, MonadError TypeError m, MonadBreadCrumbs m) =>-             loc -> String -> m a-typeError loc s = do-  bc <- getBreadCrumbs-  let bc' | null bc = ""-          | otherwise = "\n" ++ unlines (map show bc)-  throwError $ TypeError (srclocOf loc) $ s ++ bc'--class MonadError TypeError m => MonadTypeChecker m where+class Monad m => MonadTypeChecker m where   warn :: Located loc => loc -> String -> m ()    newName :: VName -> m VName@@ -229,9 +214,11 @@     (v', t) <- lookupVar loc v     case t of       Scalar (Prim (Signed Int32)) -> return v'-      _ -> throwError $ TypeError loc $-           "Dimension declaration " ++ pretty v ++ " should be of type `i32`."+      _ -> typeError loc mempty $+           "Dimension declaration" <+> ppr v <+> "should be of type i32." +  typeError :: Located loc => loc -> Notes -> Doc -> m a+ checkName :: MonadTypeChecker m => Namespace -> Name -> SrcLoc -> m VName checkName space name loc = qualLeaf <$> checkQualName space (qualName name) loc @@ -283,11 +270,13 @@         | "_" `isPrefixOf` baseString name -> underscoreUse loc qn         | otherwise ->             case getType t of-              Left{} -> throwError $ TypeError loc $-                        "Attempt to use function " ++ baseString name ++ " as value."+              Left{} -> typeError loc mempty $+                        "Attempt to use function" <+> pprName name <+> "as value."               Right t' -> return (qn', fromStruct $                                        qualifyTypeVars outer_env mempty qs t') +  typeError loc notes s = throwError $ TypeError (srclocOf loc) notes s+ -- | Extract from a type either a function type comprising a list of -- parameter types and a return type, or a first-order type. getType :: TypeBase dim as@@ -343,7 +332,8 @@                           []       -> QualName (qs++orig_qs) name          reachable [] name env =-          isJust $ find matches $ M.elems (envTypeTable env)+          name `M.member` envVtable env ||+          isJust (find matches $ M.elems (envTypeTable env))           where matches (TypeAbbr _ _ (Scalar (TypeVar _ _ (TypeName x_qs name') _))) =                   null x_qs && name == name'                 matches _ = False@@ -353,7 +343,7 @@               reachable qs' name env'           | otherwise = False -badOnLeft :: MonadTypeChecker m => Either TypeError a -> m a+badOnLeft :: Either TypeError a -> TypeM a badOnLeft = either throwError return  anySignedType :: [PrimType]@@ -375,11 +365,6 @@ anyPrimType = Bool : anyIntType ++ anyFloatType  --- Name handling--ppSpace :: Namespace -> String-ppSpace Term = "name"-ppSpace Type = "type"-ppSpace Signature = "module type"  intrinsicsNameMap :: NameMap intrinsicsNameMap = M.fromList $ map mapping $ M.toList intrinsics
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -1,2130 +1,2956 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} {-# LANGUAGE FlexibleInstances, DeriveFunctor #-} {-# Language TupleSections #-}--- | Facilities for type-checking Futhark terms.  Checking a term--- requires a little more context to track uniqueness and such.------ Type inference is implemented through a variation of--- Hindley-Milner.  The main complication is supporting the rich--- number of built-in language constructs, as well as uniqueness--- types.  This is mostly done in an ad hoc way, and many programs--- will require the programmer to fall back on type annotations.-module Language.Futhark.TypeChecker.Terms-  ( checkOneExp-  , checkFunDef-  )-where--import Control.Monad.Except-import Control.Monad.State-import Control.Monad.RWS hiding (Sum)-import qualified Control.Monad.Fail as Fail-import Data.Char (isAlpha)-import Data.List-import qualified Data.List.NonEmpty as NE-import Data.Loc-import Data.Maybe-import qualified Data.Map.Strict as M-import qualified Data.Set as S--import Prelude hiding (mod)--import Language.Futhark-import Language.Futhark.Semantic (includeToString)-import Language.Futhark.Traversals-import Language.Futhark.TypeChecker.Monad hiding (BoundV, checkQualNameWithEnv)-import Language.Futhark.TypeChecker.Types hiding (checkTypeDecl)-import Language.Futhark.TypeChecker.Unify hiding (Usage)-import qualified Language.Futhark.TypeChecker.Types as Types-import qualified Language.Futhark.TypeChecker.Monad as TypeM-import Futhark.Util.Pretty hiding (space, bool, group)----- Uniqueness--data Usage = Consumed SrcLoc-           | Observed SrcLoc-           deriving (Eq, Ord, Show)--type Names = S.Set VName---- | The consumption set is a Maybe so we can distinguish whether a--- consumption took place, but the variable went out of scope since,--- or no consumption at all took place.-data Occurence = Occurence { observed :: Names-                           , consumed :: Maybe Names-                           , location :: SrcLoc-                           }-             deriving (Eq, Show)--instance Located Occurence where-  locOf = locOf . location--observation :: Aliasing -> SrcLoc -> Occurence-observation = flip Occurence Nothing . S.map aliasVar--consumption :: Aliasing -> SrcLoc -> Occurence-consumption = Occurence S.empty . Just . S.map aliasVar---- | A null occurence is one that we can remove without affecting--- anything.-nullOccurence :: Occurence -> Bool-nullOccurence occ = S.null (observed occ) && isNothing (consumed occ)---- | A seminull occurence is one that does not contain references to--- any variables in scope.  The big difference is that a seminull--- occurence may denote a consumption, as long as the array that was--- consumed is now out of scope.-seminullOccurence :: Occurence -> Bool-seminullOccurence occ = S.null (observed occ) && maybe True S.null (consumed occ)--type Occurences = [Occurence]--type UsageMap = M.Map VName [Usage]--usageMap :: Occurences -> UsageMap-usageMap = foldl comb M.empty-  where comb m (Occurence obs cons loc) =-          let m' = S.foldl' (ins $ Observed loc) m obs-          in S.foldl' (ins $ Consumed loc) m' $ fromMaybe mempty cons-        ins v m k = M.insertWith (++) k [v] m--combineOccurences :: MonadTypeChecker m => VName -> Usage -> Usage -> m Usage-combineOccurences _ (Observed loc) (Observed _) = return $ Observed loc-combineOccurences name (Consumed wloc) (Observed rloc) =-  useAfterConsume (baseName name) rloc wloc-combineOccurences name (Observed rloc) (Consumed wloc) =-  useAfterConsume (baseName name) rloc wloc-combineOccurences name (Consumed loc1) (Consumed loc2) =-  consumeAfterConsume (baseName name) (max loc1 loc2) (min loc1 loc2)--checkOccurences :: MonadTypeChecker m => Occurences -> m ()-checkOccurences = void . M.traverseWithKey comb . usageMap-  where comb _    []     = return ()-        comb name (u:us) = foldM_ (combineOccurences name) u us--allObserved :: Occurences -> Names-allObserved = S.unions . map observed--allConsumed :: Occurences -> Names-allConsumed = S.unions . map (fromMaybe mempty . consumed)--allOccuring :: Occurences -> Names-allOccuring occs = allConsumed occs <> allObserved occs--anyConsumption :: Occurences -> Maybe Occurence-anyConsumption = find (isJust . consumed)--seqOccurences :: Occurences -> Occurences -> Occurences-seqOccurences occurs1 occurs2 =-  filter (not . nullOccurence) $ map filt occurs1 ++ occurs2-  where filt occ =-          occ { observed = observed occ `S.difference` postcons }-        postcons = allConsumed occurs2--altOccurences :: Occurences -> Occurences -> Occurences-altOccurences occurs1 occurs2 =-  filter (not . nullOccurence) $ map filt1 occurs1 ++ map filt2 occurs2-  where filt1 occ =-          occ { consumed = S.difference <$> consumed occ <*> pure cons2-              , observed = observed occ `S.difference` cons2 }-        filt2 occ =-          occ { consumed = consumed occ-              , observed = observed occ `S.difference` cons1 }-        cons1 = allConsumed occurs1-        cons2 = allConsumed occurs2----- Scope management---- | Whether something is a global or a local variable.-data Locality = Local | Global-              deriving (Show)--data ValBinding = BoundV Locality [TypeParam] PatternType-                -- ^ Aliases in parameters indicate the lexical-                -- closure.-                | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType)-                | EqualityF-                | WasConsumed SrcLoc-                deriving (Show)---- | Type checking happens with access to this environment.  The--- 'TermScope' will be extended during type-checking as bindings come into--- scope.-data TermEnv = TermEnv { termScope :: TermScope-                       , termBreadCrumbs :: [BreadCrumb]-                         -- ^ Most recent first.-                       , termLevel :: Level-                       }--data TermScope = TermScope { scopeVtable  :: M.Map VName ValBinding-                           , scopeTypeTable :: M.Map VName TypeBinding-                           , scopeModTable :: M.Map VName Mod-                           , scopeNameMap :: NameMap-                           } deriving (Show)--instance Semigroup TermScope where-  TermScope vt1 tt1 mt1 nt1 <> TermScope vt2 tt2 mt2 nt2 =-    TermScope (vt2 `M.union` vt1) (tt2 `M.union` tt1) (mt1 `M.union` mt2) (nt2 `M.union` nt1)--envToTermScope :: Env -> TermScope-envToTermScope env = TermScope { scopeVtable = vtable-                               , scopeTypeTable = envTypeTable env-                               , scopeNameMap = envNameMap env-                               , scopeModTable = envModTable env-                               }-  where vtable = M.mapWithKey valBinding $ envVtable env-        valBinding k (TypeM.BoundV tps v) =-          BoundV Global tps $ v `setAliases`-          (if arrayRank v > 0 then S.singleton (AliasBound k) else mempty)--withEnv :: TermEnv -> Env -> TermEnv-withEnv tenv env = tenv { termScope = termScope tenv <> envToTermScope env }--overloadedTypeVars :: Constraints -> Names-overloadedTypeVars = mconcat . map f . M.elems-  where f (_, HasFields fs _) = mconcat $ map typeVars $ M.elems fs-        f _ = mempty---- | Get the type of an expression, with all type variables--- substituted.  Never call 'typeOf' directly (except in a few--- carefully inspected locations)!-expType :: Exp -> TermTypeM PatternType-expType = normaliseType . typeOf---- | The state is a set of constraints and a counter for generating--- type names.  This is distinct from the usual counter we use for--- generating unique names, as these will be user-visible.-type TermTypeState = (Constraints, Int)--newtype TermTypeM a = TermTypeM (RWST-                                 TermEnv-                                 Occurences-                                 TermTypeState-                                 TypeM-                                 a)-  deriving (Monad, Functor, Applicative,-            MonadReader TermEnv,-            MonadWriter Occurences,-            MonadState TermTypeState,-            MonadError TypeError)--instance Fail.MonadFail TermTypeM where-  fail = typeError (noLoc :: SrcLoc) . ("unknown failure (likely a bug): "++)--instance MonadUnify TermTypeM where-  getConstraints = gets fst-  putConstraints x = modify $ \s -> (x, snd s)--  newTypeVar loc desc = do-    i <- incCounter-    v <- newID $ mkTypeVarName desc i-    constrain v $ NoConstraint Lifted $ mkUsage' loc-    return $ Scalar $ TypeVar mempty Nonunique (typeName v) []--  curLevel = asks termLevel--instance MonadBreadCrumbs TermTypeM where-  breadCrumb bc = local $ \env ->-    env { termBreadCrumbs = bc : termBreadCrumbs env }-  getBreadCrumbs = asks termBreadCrumbs--runTermTypeM :: TermTypeM a -> TypeM (a, Occurences)-runTermTypeM (TermTypeM m) = do-  initial_scope <- (initialTermScope <>) . envToTermScope <$> askEnv-  let initial_tenv = TermEnv { termScope = initial_scope-                             , termBreadCrumbs = mempty-                             , termLevel = 0-                             }-  evalRWST m initial_tenv (mempty, 0)--liftTypeM :: TypeM a -> TermTypeM a-liftTypeM = TermTypeM . lift--localScope :: (TermScope -> TermScope) -> TermTypeM a -> TermTypeM a-localScope f = local $ \tenv -> tenv { termScope = f $ termScope tenv }--incCounter :: TermTypeM Int-incCounter = do (x, i) <- get-                put (x, i+1)-                return i--constrain :: VName -> Constraint -> TermTypeM ()-constrain v c = do-  lvl <- curLevel-  modifyConstraints $ M.insert v (lvl, c)--incLevel :: TermTypeM a -> TermTypeM a-incLevel = local $ \env -> env { termLevel = termLevel env + 1 }--initialTermScope :: TermScope-initialTermScope = TermScope { scopeVtable = initialVtable-                             , scopeTypeTable = mempty-                             , scopeNameMap = topLevelNameMap-                             , scopeModTable = mempty-                             }-  where initialVtable = M.fromList $ mapMaybe addIntrinsicF $ M.toList intrinsics--        prim = Scalar . Prim-        arrow x y = Scalar $ Arrow mempty Unnamed x y--        addIntrinsicF (name, IntrinsicMonoFun pts t) =-          Just (name, BoundV Global [] $ arrow pts' $ prim t)-          where pts' = case pts of [pt] -> prim pt-                                   _    -> tupleRecord $ map prim pts--        addIntrinsicF (name, IntrinsicOverloadedFun ts pts rts) =-          Just (name, OverloadedF ts pts rts)-        addIntrinsicF (name, IntrinsicPolyFun tvs pts rt) =-          Just (name, BoundV Global tvs $-                      fromStruct $ anyDimShapeAnnotations $-                      Scalar $ Arrow mempty Unnamed pts' rt)-          where pts' = case pts of [pt] -> pt-                                   _    -> tupleRecord pts-        addIntrinsicF (name, IntrinsicEquality) =-          Just (name, EqualityF)-        addIntrinsicF _ = Nothing--instance MonadTypeChecker TermTypeM where-  warn loc problem = liftTypeM $ warn loc problem-  newName = liftTypeM . newName-  newID = liftTypeM . newID--  checkQualName space name loc = snd <$> checkQualNameWithEnv space name loc--  bindNameMap m = localScope $ \scope ->-    scope { scopeNameMap = m <> scopeNameMap scope }--  bindVal v (TypeM.BoundV tps t) = localScope $ \scope ->-    scope { scopeVtable = M.insert v vb $ scopeVtable scope }-    where vb = BoundV Local tps $ fromStruct t--  lookupType loc qn = do-    outer_env <- liftTypeM askEnv-    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc-    case M.lookup name $ scopeTypeTable scope of-      Nothing -> undefinedType loc qn-      Just (TypeAbbr l ps def) ->-        return (qn', ps, qualifyTypeVars outer_env (map typeParamName ps) qs def, l)--  lookupMod loc qn = do-    (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc-    case M.lookup name $ scopeModTable scope of-      Nothing -> unknownVariableError Term qn loc-      Just m  -> return (qn', m)--  lookupVar loc qn = do-    outer_env <- liftTypeM askEnv-    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc-    let usage = mkUsage loc $ "use of " ++ quote (pretty qn)--    t <- case M.lookup name $ scopeVtable scope of-      Nothing -> throwError $ TypeError loc $-                 "Unknown variable " ++ quote (pretty qn) ++ "."--      Just (WasConsumed wloc) -> useAfterConsume (baseName name) loc wloc--      Just (BoundV _ tparams t)-        | "_" `isPrefixOf` baseString name -> underscoreUse loc qn-        | otherwise -> do-            (tnames, t') <- instantiateTypeScheme loc tparams t-            let qual = qualifyTypeVars outer_env tnames qs-            qual . anyDimShapeAnnotations <$> normaliseType t'--      Just EqualityF -> do-        argtype <- newTypeVar loc "t"-        equalityType usage argtype-        return $-          Scalar $ Arrow mempty Unnamed argtype $-          Scalar $ Arrow mempty Unnamed argtype $ Scalar $ Prim Bool--      Just (OverloadedF ts pts rt) -> do-        argtype <- newTypeVar loc "t"-        mustBeOneOf ts usage argtype-        let (pts', rt') = instOverloaded argtype pts rt-            arrow xt yt = Scalar $ Arrow mempty Unnamed xt yt-        return $ fromStruct $ vacuousShapeAnnotations $ foldr arrow rt' pts'--    observe $ Ident name (Info t) loc-    return (qn', t)--      where instOverloaded argtype pts rt =-              (map (maybe (toStruct argtype) (Scalar . Prim)) pts,-               maybe (toStruct argtype) (Scalar . Prim) rt)--  checkNamedDim loc v = do-    (v', t) <- lookupVar loc v-    unify (mkUsage loc "use as array size") (toStructural t) $-      Scalar $ Prim $ Signed Int32-    return v'--checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkQualNameWithEnv space qn@(QualName quals name) loc = do-  scope <- asks termScope-  descend scope quals-  where descend scope []-          | Just name' <- M.lookup (space, name) $ scopeNameMap scope =-              return (scope, name')-          | otherwise =-              unknownVariableError space qn loc--        descend scope (q:qs)-          | Just (QualName _ q') <- M.lookup (Term, q) $ scopeNameMap scope,-            Just res <- M.lookup q' $ scopeModTable scope =-              case res of-                -- Check if we are referring to the magical intrinsics-                -- module.-                _ | baseTag q' <= maxIntrinsicTag ->-                      checkIntrinsic space qn loc-                ModEnv q_scope -> do-                  (scope', QualName qs' name') <- descend (envToTermScope q_scope) qs-                  return (scope', QualName (q':qs') name')-                ModFun{} -> unappliedFunctor loc-          | otherwise =-              unknownVariableError space qn loc--checkIntrinsic :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkIntrinsic space qn@(QualName _ name) loc-  | Just v <- M.lookup (space, name) intrinsicsNameMap = do-      me <- liftTypeM askImportName-      unless ("/futlib" `isPrefixOf` includeToString me) $-        warn loc "Using intrinsic functions directly can easily crash the compiler or result in wrong code generation."-      scope <- asks termScope-      return (scope, v)-  | otherwise =-      unknownVariableError space qn loc---- | Wrap 'Types.checkTypeDecl' to also perform an observation of--- every size in the type.-checkTypeDecl :: TypeDeclBase NoInfo Name -> TermTypeM (TypeDeclBase Info VName)-checkTypeDecl tdecl = do-  (tdecl', _) <- Types.checkTypeDecl [] tdecl-  mapM_ observeDim $ nestedDims $ unInfo $ expandedType tdecl'-  return tdecl'-  where observeDim (NamedDim v) =-          observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int32) noLoc-        observeDim _ = return ()---- | Instantiate a type scheme with fresh type variables for its type--- parameters. Returns the names of the fresh type variables, the instance--- list, and the instantiated type.-instantiateTypeScheme :: SrcLoc -> [TypeParam] -> PatternType-                      -> TermTypeM ([VName], PatternType)-instantiateTypeScheme loc tparams t = do-  let tparams' = filter isTypeParam tparams-      tnames = map typeParamName tparams'-  (fresh_tnames, substs) <- unzip <$> mapM (instantiateTypeParam loc) tparams'-  let substs' = M.fromList $ zip tnames substs-      t' = substTypesAny (`M.lookup` substs') t-  return (fresh_tnames, t')---- | Create a new type name and insert it (unconstrained) in the--- substitution map.-instantiateTypeParam :: Monoid as => SrcLoc -> TypeParam -> TermTypeM (VName, Subst (TypeBase dim as))-instantiateTypeParam loc tparam = do-  i <- incCounter-  v <- newID $ mkTypeVarName (takeWhile isAlpha (baseString (typeParamName tparam))) i-  constrain v $ NoConstraint l $ mkUsage' loc-  return (v, Subst $ Scalar $ TypeVar mempty Nonunique (typeName v) [])-  where l = case tparam of TypeParamType x _ _ -> x-                           _                   -> Lifted--newArrayType :: SrcLoc -> String -> Int -> TermTypeM (TypeBase () (), TypeBase () ())-newArrayType loc desc r = do-  v <- newID $ nameFromString desc-  constrain v $ NoConstraint Unlifted $ mkUsage' loc-  let rowt = TypeVar () Nonunique (typeName v) []-  return (Array () Nonunique rowt (ShapeDecl $ replicate r ()),-          Scalar rowt)----- Errors--funName :: Maybe Name -> String-funName Nothing = "anonymous function"-funName (Just fname) = "function " ++ quote (pretty fname)--useAfterConsume :: MonadTypeChecker m => Name -> SrcLoc -> SrcLoc -> m a-useAfterConsume name rloc wloc =-  throwError $ TypeError rloc $-  "Variable " ++ quote (pretty name) ++ " previously consumed at " ++-  locStr wloc ++ ".  (Possibly through aliasing)"--consumeAfterConsume :: MonadTypeChecker m => Name -> SrcLoc -> SrcLoc -> m a-consumeAfterConsume name loc1 loc2 =-  throwError $ TypeError loc2 $-  "Variable " ++ pretty name ++ " previously consumed at " ++ locStr loc1 ++ "."--badLetWithValue :: MonadTypeChecker m => SrcLoc -> m a-badLetWithValue loc =-  throwError $ TypeError loc-  "New value for elements in let-with shares data with source array.  This is illegal, as it prevents in-place modification."--returnAliased :: MonadTypeChecker m => Maybe Name -> Name -> SrcLoc -> m ()-returnAliased fname name loc =-  throwError $ TypeError loc $-  "Unique return value of " ++ funName fname ++-  " is aliased to " ++ quote (pretty name) ++ ", which is not consumed."--uniqueReturnAliased :: MonadTypeChecker m => Maybe Name -> SrcLoc -> m a-uniqueReturnAliased fname loc =-  throwError $ TypeError loc $-  "A unique tuple element of return value of " ++-  funName fname ++ " is aliased to some other tuple component."----- Basic checking---- | Determine if two types are identical, ignoring uniqueness.--- Causes a 'TypeError' if they fail to match, and otherwise returns--- one of them.-unifyExpTypes :: Exp -> Exp -> TermTypeM PatternType-unifyExpTypes e1 e2 = do-  e1_t <- expType e1-  e2_t <- expType e2-  unify (mkUsage (srclocOf e2) "requiring equality of types") (toStructural e1_t) (toStructural e2_t)-  return $ unifyTypeAliases e1_t e2_t---- | Assumes that the two types have already been unified.-unifyTypeAliases :: PatternType -> PatternType -> PatternType-unifyTypeAliases t1 t2 =-  case (t1, t2) of-    (Array als1 u1 et1 shape1, Array als2 u2 _ _) ->-      Array (als1<>als2) (min u1 u2) et1 shape1-    (Scalar (Record f1), Scalar (Record f2)) ->-      Scalar $ Record $ M.intersectionWith unifyTypeAliases f1 f2-    (Scalar (TypeVar als1 u v targs1), Scalar (TypeVar als2 _ _ targs2)) ->-      Scalar $ TypeVar (als1 <> als2) u v $ zipWith unifyTypeArg targs1 targs2-    _ -> t1-  where unifyTypeArg (TypeArgType t1' loc) (TypeArgType _ _) =-          TypeArgType t1' loc-        unifyTypeArg a _ = a----- General binding.--doNotShadow :: [String]-doNotShadow = ["&&", "||"]--data InferredType = NoneInferred-                  | Ascribed PatternType---checkPattern' :: UncheckedPattern -> InferredType-              -> TermTypeM Pattern--checkPattern' (PatternParens p loc) t =-  PatternParens <$> checkPattern' p t <*> pure loc--checkPattern' (Id name _ loc) _-  | name' `elem` doNotShadow =-      typeError loc $ "The " ++ name' ++ " operator may not be redefined."-  where name' = nameToString name--checkPattern' (Id name NoInfo loc) (Ascribed t) = do-  name' <- newID name-  return $ Id name' (Info t) loc-checkPattern' (Id name NoInfo loc) NoneInferred = do-  name' <- newID name-  t <- newTypeVar loc "t"-  return $ Id name' (Info t) loc--checkPattern' (Wildcard _ loc) (Ascribed t) =-  return $ Wildcard (Info $ t `setUniqueness` Nonunique) loc-checkPattern' (Wildcard NoInfo loc) NoneInferred = do-  t <- newTypeVar loc "t"-  return $ Wildcard (Info t) loc--checkPattern' (TuplePattern ps loc) (Ascribed t)-  | Just ts <- isTupleRecord t, length ts == length ps =-      TuplePattern <$> zipWithM checkPattern' ps (map Ascribed ts) <*> pure loc-checkPattern' p@(TuplePattern ps loc) (Ascribed t) = do-  ps_t <- replicateM (length ps) (newTypeVar loc "t")-  unify (mkUsage loc "matching a tuple pattern") (tupleRecord ps_t) $ toStructural t-  t' <- normaliseType t-  checkPattern' p $ Ascribed t'-checkPattern' (TuplePattern ps loc) NoneInferred =-  TuplePattern <$> mapM (`checkPattern'` NoneInferred) ps <*> pure loc--checkPattern' (RecordPattern p_fs _) _-  | Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs =-      typeError fp $ unlines [ "Underscore-prefixed fields are not allowed."-                             , "Did you mean " ++-                               quote (drop 1 (nameToString f) ++ "=_") ++ "?"]--checkPattern' (RecordPattern p_fs loc) (Ascribed (Scalar (Record t_fs)))-  | sort (map fst p_fs) == sort (M.keys t_fs) =-    RecordPattern . M.toList <$> check <*> pure loc-    where check = traverse (uncurry checkPattern') $ M.intersectionWith (,)-                  (M.fromList p_fs) (fmap Ascribed t_fs)-checkPattern' p@(RecordPattern fields loc) (Ascribed t) = do-  fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields--  when (sort (M.keys fields') /= sort (map fst fields)) $-    typeError loc $ "Duplicate fields in record pattern " ++ pretty p--  unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStructural t-  t' <- normaliseType t-  checkPattern' p $ Ascribed t'-checkPattern' (RecordPattern fs loc) NoneInferred =-  RecordPattern . M.toList <$> traverse (`checkPattern'` NoneInferred) (M.fromList fs) <*> pure loc--checkPattern' (PatternAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do-  (t', st, _) <- checkTypeExp t--  let st' = fromStruct st-  case maybe_outer_t of-    Ascribed outer_t -> do-      unify (mkUsage loc "explicit type ascription") (toStructural st) (toStructural outer_t)--      -- We also have to make sure that uniqueness and shapes match.-      -- This is done explicitly, because they are ignored by-      -- unification.-      st'' <- normaliseType st'-      outer_t' <- normaliseType outer_t-      case unifyTypesU unifyUniqueness st' outer_t' of-        Just outer_t'' ->-          PatternAscription <$> checkPattern' p (Ascribed outer_t'') <*>-          pure (TypeDecl t' (Info st)) <*> pure loc-        Nothing ->-          typeError loc $ "Cannot match type " ++ quote (pretty outer_t') ++ " with expected type " ++-          quote (pretty st'') ++ "."--    NoneInferred ->-      PatternAscription <$> checkPattern' p (Ascribed st') <*>-      pure (TypeDecl t' (Info st)) <*> pure loc- where unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing--checkPattern' (PatternLit e NoInfo loc) (Ascribed t) = do-  e' <- checkExp e-  t' <- expType e'-  unify (mkUsage loc "matching against literal") (toStructural t') (toStructural t)-  return $ PatternLit e' (Info t') loc--checkPattern' (PatternLit e NoInfo loc) NoneInferred = do-  e' <- checkExp e-  t' <- expType e'-  return $ PatternLit e' (Info t') loc--checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))-  | Just ts <- M.lookup n cs = do-      ps' <- zipWithM checkPattern' ps $ map Ascribed ts-      return $ PatternConstr n (Info (Scalar (Sum cs))) ps' loc--checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed t) = do-  t' <- newTypeVar loc "t"-  ps' <- mapM (`checkPattern'` NoneInferred) ps-  mustHaveConstr usage n t' (toStructural . patternType <$> ps')-  unify usage t' (toStructural t)-  t'' <- normaliseType t-  return $ PatternConstr n (Info t'') ps' loc-  where usage = mkUsage loc "matching against constructor"--checkPattern' (PatternConstr n NoInfo ps loc) NoneInferred = do-  ps' <- mapM (`checkPattern'` NoneInferred) ps-  t <- newTypeVar loc "t"-  mustHaveConstr usage n t (toStructural . patternType <$> ps')-  return $ PatternConstr n (Info t) ps' loc-  where usage = mkUsage loc "matching against constructor"--patternNameMap :: Pattern -> NameMap-patternNameMap = M.fromList . map asTerm . S.toList . patternIdents-  where asTerm v = ((Term, baseName $ identName v), qualName $ identName v)--checkPattern :: UncheckedPattern -> InferredType -> (Pattern -> TermTypeM a)-             -> TermTypeM a-checkPattern p t m = do-  checkForDuplicateNames [p]-  p' <- checkPattern' p t-  bindNameMap (patternNameMap p') $ m p'--binding :: [Ident] -> TermTypeM a -> TermTypeM a-binding bnds = check . localScope (`bindVars` bnds)-  where bindVars :: TermScope -> [Ident] -> TermScope-        bindVars = foldl bindVar--        bindVar :: TermScope -> Ident -> TermScope-        bindVar scope (Ident name (Info tp) _) =-          let inedges = boundAliases $ aliases tp-              update (BoundV l tparams in_t)-                -- If 'name' is record or sum-typed, don't alias the-                -- components to 'name', because these no identity-                -- beyond their components.-                | Array{} <- tp = BoundV l tparams (in_t `addAliases` S.insert (AliasBound name))-                | otherwise = BoundV l tparams in_t-              update b = b--              tp' = tp `addAliases` S.insert (AliasBound name)-          in scope { scopeVtable = M.insert name (BoundV Local [] tp') $-                                   adjustSeveral update inedges $-                                   scopeVtable scope-                   }--        adjustSeveral f = flip $ foldl $ flip $ M.adjust f--        -- Check whether the bound variables have been used correctly-        -- within their scope.-        check m = do-          (a, usages) <- collectBindingsOccurences m-          checkOccurences usages--          mapM_ (checkIfUsed usages) bnds--          return a--        -- Collect and remove all occurences in @bnds@.  This relies-        -- on the fact that no variables shadow any other.-        collectBindingsOccurences m = pass $ do-          (x, usage) <- listen m-          let (relevant, rest) = split usage-          return ((x, relevant), const rest)-          where split = unzip .-                        map (\occ ->-                             let (obs1, obs2) = divide $ observed occ-                                 occ_cons = divide <$> consumed occ-                                 con1 = fst <$> occ_cons-                                 con2 = snd <$> occ_cons-                             in (occ { observed = obs1, consumed = con1 },-                                 occ { observed = obs2, consumed = con2 }))-                names = S.fromList $ map identName bnds-                divide s = (s `S.intersection` names, s `S.difference` names)--bindingTypes :: [(VName, (TypeBinding, Constraint))] -> TermTypeM a -> TermTypeM a-bindingTypes types m = do-  lvl <- curLevel-  modifyConstraints (<>M.map ((lvl,) . snd) (M.fromList types))-  localScope extend m-  where extend scope = scope {-          scopeTypeTable = M.map fst (M.fromList types) <> scopeTypeTable scope-          }--bindingTypeParams :: [TypeParam] -> TermTypeM a -> TermTypeM a-bindingTypeParams tparams = binding (mapMaybe typeParamIdent tparams) .-                            bindingTypes (mapMaybe typeParamType tparams)-  where typeParamType (TypeParamType l v loc) =-          Just (v, (TypeAbbr l [] (Scalar (TypeVar () Nonunique (typeName v) [])),-                    ParamType l loc))-        typeParamType TypeParamDim{} =-          Nothing--typeParamIdent :: TypeParam -> Maybe Ident-typeParamIdent (TypeParamDim v loc) =-  Just $ Ident v (Info $ Scalar $ Prim $ Signed Int32) loc-typeParamIdent _ = Nothing--bindingIdent :: IdentBase NoInfo Name -> PatternType -> (Ident -> TermTypeM a)-             -> TermTypeM a-bindingIdent (Ident v NoInfo vloc) t m =-  bindSpaced [(Term, v)] $ do-    v' <- checkName Term v vloc-    let ident = Ident v' (Info t) vloc-    binding [ident] $ m ident--bindingPatternGroup :: [UncheckedTypeParam]-                    -> [UncheckedPattern]-                    -> ([TypeParam] -> [Pattern] -> TermTypeM a) -> TermTypeM a-bindingPatternGroup tps orig_ps m = do-  checkForDuplicateNames orig_ps-  checkTypeParams tps $ \tps' -> bindingTypeParams tps' $ do-    let descend ps' (p:ps) =-          checkPattern p NoneInferred $ \p' ->-            binding (S.toList $ patternIdents p') $ descend (p':ps') ps-        descend ps' [] = do-          -- Perform an observation of every type parameter.  This-          -- prevents unused-name warnings for otherwise unused-          -- dimensions.-          mapM_ observe $ mapMaybe typeParamIdent tps'-          let ps'' = reverse ps'-          checkShapeParamUses tps' $ map patternStructType ps''--          m tps' ps''--    descend [] orig_ps--bindingPattern :: PatternBase NoInfo Name -> InferredType-               -> (Pattern -> TermTypeM a) -> TermTypeM a-bindingPattern p t m = do-  checkForDuplicateNames [p]-  checkPattern p t $ \p' -> binding (S.toList $ patternIdents p') $ do-    -- Perform an observation of every declared dimension.  This-    -- prevents unused-name warnings for otherwise unused dimensions.-    mapM_ observe $ patternDims p'--    m p'--patternDims :: Pattern -> [Ident]-patternDims (PatternParens p _) = patternDims p-patternDims (TuplePattern pats _) = concatMap patternDims pats-patternDims (PatternAscription p (TypeDecl _ (Info t)) _) =-  patternDims p <> mapMaybe (dimIdent (srclocOf p)) (nestedDims t)-  where dimIdent _ AnyDim            = Nothing-        dimIdent _ (ConstDim _)      = Nothing-        dimIdent _ NamedDim{}        = Nothing-patternDims _ = []----- Main checkers---- | @require ts e@ causes a 'TypeError' if @expType e@ is not one of--- the types in @ts@.  Otherwise, simply returns @e@.-require :: String -> [PrimType] -> Exp -> TermTypeM Exp-require why ts e = do mustBeOneOf ts (mkUsage (srclocOf e) why) . toStructural =<< expType e-                      return e--unifies :: String -> TypeBase () () -> Exp -> TermTypeM Exp-unifies why t e = do-  unify (mkUsage (srclocOf e) why) t =<< toStructural <$> expType e-  return e---- The closure of a lambda or local function are those variables that--- it references, and which local to the current top-level function.-lexicalClosure :: [Pattern] -> Occurences -> TermTypeM Aliasing-lexicalClosure params closure = do-  vtable <- asks $ scopeVtable . termScope-  let isLocal v = case v `M.lookup` vtable of-                    Just (BoundV Local _ _) -> True-                    _ -> False-  return $ S.map AliasBound $ S.filter isLocal $-    allOccuring closure S.\\-    S.map identName (mconcat (map patternIdents params))--checkExp :: UncheckedExp -> TermTypeM Exp--checkExp (Literal val loc) =-  return $ Literal val loc--checkExp (StringLit vs loc) =-  return $ StringLit vs loc--checkExp (IntLit val NoInfo loc) = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t-  return $ IntLit val (Info $ vacuousShapeAnnotations $ fromStruct t) loc--checkExp (FloatLit val NoInfo loc) = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyFloatType (mkUsage loc "float literal") t-  return $ FloatLit val (Info $ vacuousShapeAnnotations $ fromStruct t) loc--checkExp (TupLit es loc) =-  TupLit <$> mapM checkExp es <*> pure loc--checkExp (RecordLit fs loc) = do-  fs' <- evalStateT (mapM checkField fs) mempty--  return $ RecordLit fs' loc-  where checkField (RecordFieldExplicit f e rloc) = do-          errIfAlreadySet f rloc-          modify $ M.insert f rloc-          RecordFieldExplicit f <$> lift (checkExp e) <*> pure rloc-        checkField (RecordFieldImplicit name NoInfo rloc) = do-          errIfAlreadySet name rloc-          (QualName _ name', t) <- lift $ lookupVar rloc $ qualName name-          modify $ M.insert name rloc-          return $ RecordFieldImplicit name' (Info t) rloc--        errIfAlreadySet f rloc = do-          maybe_sloc <- gets $ M.lookup f-          case maybe_sloc of-            Just sloc ->-              lift $ typeError rloc $ "Field '" ++ pretty f ++-              " previously defined at " ++ locStr sloc ++ "."-            Nothing -> return ()--checkExp (ArrayLit all_es _ loc) =-  -- Construct the result type and unify all elements with it.  We-  -- only create a type variable for empty arrays; otherwise we use-  -- the type of the first element.  This significantly cuts down on-  -- the number of type variables generated for pathologically large-  -- multidimensional array literals.-  case all_es of-    [] -> do et <- newTypeVar loc "t"-             t <- arrayOfM loc et (ShapeDecl [AnyDim]) Unique-             return $ ArrayLit [] (Info t) loc-    e:es -> do-      e' <- checkExp e-      et <- expType e'-      es' <- mapM (unifies "type of first array element" (toStructural et) <=< checkExp) es-      et' <- normaliseType et-      t <- arrayOfM loc et' (ShapeDecl [AnyDim]) Unique-      return $ ArrayLit (e':es') (Info t) loc--checkExp (Range start maybe_step end NoInfo loc) = do-  start' <- require "use in range expression" anyIntType =<< checkExp start-  start_t <- toStructural <$> expType start'-  maybe_step' <- case maybe_step of-    Nothing -> return Nothing-    Just step -> do-      let warning = warn loc "First and second element of range are identical, this will produce an empty array."-      case (start, step) of-        (Literal x _, Literal y _) -> when (x == y) warning-        (Var x_name _ _, Var y_name _ _) -> when (x_name == y_name) warning-        _ -> return ()-      Just <$> (unifies "use in range expression" start_t =<< checkExp step)--  end' <- case end of-    DownToExclusive e -> DownToExclusive <$>-                         (unifies "use in range expression" start_t =<< checkExp e)-    UpToExclusive e -> UpToExclusive <$>-                       (unifies "use in range expression" start_t =<< checkExp e)-    ToInclusive e -> ToInclusive <$>-                     (unifies "use in range expression" start_t =<< checkExp e)--  t <- arrayOfM loc (vacuousShapeAnnotations start_t) (rank 1) Unique--  return $ Range start' maybe_step' end'-    (Info (t `setAliases` mempty)) loc--checkExp (Ascript e decl NoInfo loc) = do-  decl' <- checkTypeDecl decl-  e' <- checkExp e-  t <- expType e'-  let decl_t = unInfo $ expandedType decl'-  unify (mkUsage loc "explicit type ascription") (toStructural decl_t) (toStructural t)--  -- We also have to make sure that uniqueness matches.  This is done-  -- explicitly, because uniqueness is ignored by unification.-  t' <- normaliseType t-  decl_t' <- normaliseType decl_t-  unless (t' `subtypeOf` anyDimShapeAnnotations decl_t') $-    typeError loc $ "Type " ++ quote (pretty t') ++ " is not a subtype of " ++-    quote (pretty decl_t') ++ "."--  let t'' = flip unifyTypeAliases t' $ combineTypeShapes t' $ fromStruct decl_t'-  return $ Ascript e' decl' (Info t'') loc--checkExp (BinOp (op, oploc) NoInfo (e1,_) (e2,_) NoInfo loc) = do-  (op', ftype) <- lookupVar oploc op-  (e1', e1_arg) <- checkArg e1-  (e2', e2_arg) <- checkArg e2--  (p1_t, rt) <- checkApply loc ftype e1_arg-  (p2_t, rt') <- checkApply loc rt e2_arg--  return $ BinOp (op', oploc) (Info ftype)-    (e1', Info $ toStruct p1_t) (e2', Info $ toStruct p2_t)-    (Info rt') loc--checkExp (Project k e NoInfo loc) = do-  e' <- checkExp e-  t <- expType e'-  kt <- mustHaveField (mkUsage loc $ "projection of field " ++ quote (pretty k)) k t-  return $ Project k e' (Info kt) loc--checkExp (If e1 e2 e3 _ loc) =-  sequentially checkCond $ \e1' _ -> do-  ((e2', e3'), dflow) <- tapOccurences $ checkExp e2 `alternative` checkExp e3-  brancht <- unifyExpTypes e2' e3'-  let t' = addAliases brancht (`S.difference` S.map AliasBound (allConsumed dflow))-  zeroOrderType (mkUsage loc "returning value of this type from 'if' expression") "returned from branch" t'-  return $ If e1' e2' e3' (Info t') loc-  where checkCond = do-          e1' <- checkExp e1-          unify (mkUsage (srclocOf e1') "use as 'if' condition") (Scalar $ Prim Bool) . toStructural =<< expType e1'-          return e1'--checkExp (Parens e loc) =-  Parens <$> checkExp e <*> pure loc--checkExp (QualParens (modname, modnameloc) e loc) = do-  (modname',mod) <- lookupMod loc modname-  case mod of-    ModEnv env -> local (`withEnv` qualifyEnv modname' env) $ do-      e' <- checkExp e-      return $ QualParens (modname', modnameloc) e' loc-    ModFun{} ->-      typeError loc $ "Module " ++ pretty modname ++ " is a parametric module."-  where qualifyEnv modname' env =-          env { envNameMap = M.map (qualify' modname') $ envNameMap env }-        qualify' modname' (QualName qs name) =-          QualName (qualQuals modname' ++ [qualLeaf modname'] ++ qs) name--checkExp (Var qn NoInfo loc) = do-  -- The qualifiers of a variable is divided into two parts: first a-  -- possibly-empty sequence of module qualifiers, followed by a-  -- possible-empty sequence of record field accesses.  We use scope-  -- information to perform the split, by taking qualifiers off the-  -- end until we find a module.--  (qn', t, fields) <- findRootVar (qualQuals qn) (qualLeaf qn)--  foldM checkField (Var qn' (Info t) loc) fields--  where findRootVar qs name =-          (whenFound <$> lookupVar loc (QualName qs name)) `catchError` notFound qs name--        whenFound (qn', t) = (qn', t, [])--        notFound qs name err-          | null qs = throwError err-          | otherwise = do-              (qn', t, fields) <- findRootVar (init qs) (last qs) `catchError`-                                  const (throwError err)-              return (qn', t, fields++[name])--        checkField e k = do-          t <- expType e-          let usage = mkUsage loc $ "projection of field " ++ quote (pretty k)-          kt <- mustHaveField usage k t-          return $ Project k e (Info kt) loc--checkExp (Negate arg loc) = do-  arg' <- require "numeric negation" anyNumberType =<< checkExp arg-  return $ Negate arg' loc--checkExp (Apply e1 e2 NoInfo NoInfo loc) = do-  e1' <- checkExp e1-  (e2', arg) <- checkArg e2-  t <- expType e1'-  (t1, rt) <- checkApply loc t arg-  return $ Apply e1' e2' (Info $ diet t1) (Info rt) loc--checkExp (LetPat pat e body NoInfo loc) =-  sequentially (checkExp e) $ \e' e_occs -> do-    -- Not technically an ascription, but we want the pattern to have-    -- exactly the type of 'e'.-    t <- expType e'-    case anyConsumption e_occs of-      Just c ->-        let msg = "of value computed with consumption at " ++ locStr (location c)-        in zeroOrderType (mkUsage loc "consumption in right-hand side of 'let'-binding") msg t-      _ -> return ()--    incLevel $ bindingPattern pat (Ascribed $ anyDimShapeAnnotations t) $ \pat' -> do-      body' <- checkExp body-      body_t <- unscopeType (S.map identName $ patternIdents pat') <$> expType body'-      return $ LetPat pat' e' body' (Info body_t) loc--checkExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body loc) =-  sequentially (checkBinding (Just name, maybe_retdecl, tparams, params, e, loc)) $-  \(tparams', params', maybe_retdecl', rettype, e') closure -> do--    closure' <- lexicalClosure params' closure--    bindSpaced [(Term, name)] $ do-      name' <- checkName Term name loc--      let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt-          ftype = foldr (arrow . patternParam) rettype params'-          entry = BoundV Local tparams' $ ftype `setAliases` closure'-          bindF scope = scope { scopeVtable = M.insert name' entry $ scopeVtable scope-                              , scopeNameMap = M.insert (Term, name) (qualName name') $-                                               scopeNameMap scope }-      body' <- localScope bindF $ checkExp body--      return $ LetFun name' (tparams', params', maybe_retdecl', Info rettype, e') body' loc--checkExp (LetWith dest src idxes ve body NoInfo loc) = do-  (t, _) <- newArrayType (srclocOf src) "src" $ length idxes-  let elemt = stripArray (length $ filter isFix idxes) t-  sequentially (checkIdent src) $ \src' _ -> do-    let src'' = Var (qualName $ identName src') (identType src') (srclocOf src)-    void $ unifies "type of target array" t src''--    unless (unique $ unInfo $ identType src') $-      typeError loc $ "Source " ++ quote (pretty (identName src)) ++-      " has type " ++ pretty (unInfo $ identType src') ++ ", which is not unique."-    vtable <- asks $ scopeVtable . termScope-    forM_ (aliases $ unInfo $ identType src') $ \v ->-      case aliasVar v `M.lookup` vtable of-        Just (BoundV Local _ v_t)-          | not $ unique v_t ->-              typeError loc $ "Source " ++ quote (pretty (identName src)) ++-              " aliases " ++ quote (prettyName (aliasVar v)) ++ ", which is not consumable."-        _ -> return ()--    idxes' <- mapM checkDimIndex idxes-    sequentially (unifies "type of target array" elemt =<< checkExp ve) $ \ve' _ -> do-      ve_t <- expType ve'-      when (AliasBound (identName src') `S.member` aliases ve_t) $-        badLetWithValue loc--      bindingIdent dest (unInfo (identType src') `setAliases` S.empty) $ \dest' -> do-        body' <- consuming src' $ checkExp body-        body_t <- unscopeType (S.singleton $ identName dest') <$> expType body'-        return $ LetWith dest' src' idxes' ve' body' (Info body_t) loc-  where isFix DimFix{} = True-        isFix _        = False--checkExp (Update src idxes ve loc) = do-  (t, _) <- newArrayType (srclocOf src) "src" $ length idxes-  let elemt = stripArray (length $ filter isFix idxes) t-  sequentially (checkExp ve >>= unifies "type of target array" elemt) $ \ve' _ ->-    sequentially (checkExp src >>= unifies "type of target array" t) $ \src' _ -> do--    idxes' <- mapM checkDimIndex idxes--    src_t <- expType src'-    unless (unique src_t) $-      typeError loc $ "Source " ++ quote (pretty src) ++-      " has type " ++ pretty src_t ++ ", which is not unique"--    let src_als = aliases src_t-    ve_t <- expType ve'-    unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue loc--    consume loc src_als-    return $ Update src' idxes' ve' loc-  where isFix DimFix{} = True-        isFix _        = False---- Record updates are a bit hacky, because we do not have row typing--- (yet?).  For now, we only permit record updates where we know the--- full type up to the field we are updating.-checkExp (RecordUpdate src fields ve NoInfo loc) = do-  src' <- checkExp src-  ve' <- checkExp ve-  a <- expType src'-  let usage = mkUsage loc "record update"-  r <- foldM (flip $ mustHaveField usage) a fields-  ve_t <- expType ve'-  unify usage (toStructural r) (toStructural ve_t)-  maybe_a' <- onRecordField (const ve_t) fields <$> expType src'-  case maybe_a' of-    Just a' -> return $ RecordUpdate src' fields ve' (Info a') loc-    Nothing -> typeError loc $ pretty $-               text "Full type of" </>-               indent 2 (ppr src) </>-               text " is not known at this point.  Add a size annotation to the original record to disambiguate."--checkExp (Index e idxes NoInfo loc) = do-  (t, _) <- newArrayType (srclocOf e) "e" $ length idxes-  e' <- unifies "being indexed at" t =<< checkExp e-  idxes' <- mapM checkDimIndex idxes-  t' <- anyDimShapeAnnotations .-        stripArray (length $ filter isFix idxes) <$>-        normaliseType (typeOf e')-  return $ Index e' idxes' (Info t') loc-  where isFix DimFix{} = True-        isFix _        = False--checkExp (Unsafe e loc) =-  Unsafe <$> checkExp e <*> pure loc--checkExp (Assert e1 e2 NoInfo loc) = do-  e1' <- require "being asserted" [Bool] =<< checkExp e1-  e2' <- checkExp e2-  return $ Assert e1' e2' (Info (pretty e1)) loc--checkExp (Lambda params body rettype_te NoInfo loc) =-  removeSeminullOccurences $ incLevel $-  bindingPatternGroup [] params $ \_ params' -> do-    rettype_checked <- traverse checkTypeExp rettype_te-    let declared_rettype =-          case rettype_checked of Just (_, st, _) -> Just st-                                  Nothing -> Nothing-    (body', closure) <--      tapOccurences $ noUnique $ checkFunBody body declared_rettype loc-    body_t <- expType body'-    let (rettype', rettype_st) =-          case rettype_checked of-            Just (te, st, _) -> (Just te, st)-            Nothing -> (Nothing, inferReturnUniqueness params' body_t)--    checkGlobalAliases params' body_t loc--    closure' <- lexicalClosure params' closure--    return $ Lambda params' body' rettype' (Info (closure', rettype_st)) loc--checkExp (OpSection op _ loc) = do-  (op', ftype) <- lookupVar loc op-  return $ OpSection op' (Info ftype) loc--checkExp (OpSectionLeft op _ e _ _ loc) = do-  (op', ftype) <- lookupVar loc op-  (e', e_arg) <- checkArg e-  (t1, rt) <- checkApply loc ftype e_arg-  case rt of-    Scalar (Arrow _ _ t2 rettype) ->-      return $ OpSectionLeft op' (Info ftype) e'-      (Info $ toStruct t1, Info $ toStruct t2) (Info rettype) loc-    _ -> typeError loc $-         "Operator section with invalid operator of type " ++ pretty ftype--checkExp (OpSectionRight op _ e _ _ loc) = do-  (op', ftype) <- lookupVar loc op-  (e', e_arg) <- checkArg e-  case ftype of-    Scalar (Arrow as1 m1 t1 (Scalar (Arrow as2 m2 t2 ret))) -> do-      (t2', Scalar (Arrow _ _ t1' rettype)) <--        checkApply loc (Scalar $ Arrow as2 m2 t2 $ Scalar $ Arrow as1 m1 t1 ret) e_arg-      return $ OpSectionRight op' (Info ftype) e'-        (Info $ toStruct t1', Info $ toStruct t2') (Info rettype) loc-    _ -> typeError loc $-         "Operator section with invalid operator of type " ++ pretty ftype--checkExp (ProjectSection fields NoInfo loc) = do-  a <- newTypeVar loc "a"-  let usage = mkUsage loc "projection at"-  b <- foldM (flip $ mustHaveField usage) a fields-  return $ ProjectSection fields (Info $ Scalar $ Arrow mempty Unnamed a b) loc--checkExp (IndexSection idxes NoInfo loc) = do-  (t, _) <- newArrayType loc "e" (length idxes)-  idxes' <- mapM checkDimIndex idxes-  let t' = stripArray (length $ filter isFix idxes) t-  return $ IndexSection idxes' (Info $ vacuousShapeAnnotations $ fromStruct $-                                Scalar $ Arrow mempty Unnamed t t') loc-  where isFix DimFix{} = True-        isFix _        = False--checkExp (DoLoop mergepat mergeexp form loopbody loc) =-  sequentially (checkExp mergeexp) $ \mergeexp' _ -> do--  zeroOrderType (mkUsage (srclocOf mergeexp) "use as loop variable")-    "used as loop variable" (typeOf mergeexp')--  merge_t <- do-    merge_t <- expType mergeexp'-    return $ Ascribed $ anyDimShapeAnnotations $ merge_t `setAliases` mempty--  -- First we do a basic check of the loop body to figure out which of-  -- the merge parameters are being consumed.  For this, we first need-  -- to check the merge pattern, which requires the (initial) merge-  -- expression.-  ---  -- Play a little with occurences to ensure it does not look like-  -- none of the merge variables are being used.-  ((mergepat', form', loopbody'), bodyflow) <--    case form of-      For i uboundexp -> do-        uboundexp' <- require "being the bound in a 'for' loop" anySignedType =<< checkExp uboundexp-        bound_t <- expType uboundexp'-        bindingIdent i bound_t $ \i' ->-          noUnique $ bindingPattern mergepat merge_t $-          \mergepat' -> onlySelfAliasing $ tapOccurences $ do-            loopbody' <- checkExp loopbody-            return (mergepat',-                    For i' uboundexp',-                    loopbody')--      ForIn xpat e -> do-        (arr_t, _) <- newArrayType (srclocOf e) "e" 1-        e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e-        t <- expType e'-        case t of-          _ | Just t' <- peelArray 1 t ->-                bindingPattern xpat (Ascribed t') $ \xpat' ->-                noUnique $ bindingPattern mergepat merge_t $-                \mergepat' -> onlySelfAliasing $ tapOccurences $ do-                  loopbody' <- checkExp loopbody-                  return (mergepat',-                          ForIn xpat' e',-                          loopbody')-            | otherwise ->-                typeError (srclocOf e) $-                "Iteratee of a for-in loop must be an array, but expression has type " ++ pretty t--      While cond ->-        noUnique $ bindingPattern mergepat merge_t $ \mergepat' ->-        onlySelfAliasing $ tapOccurences $-        sequentially (checkExp cond >>=-                      unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool)) $ \cond' _ -> do-          loopbody' <- checkExp loopbody-          return (mergepat',-                  While cond',-                  loopbody')--  mergepat'' <- do-    loop_t <- expType loopbody'-    convergePattern mergepat' (allConsumed bodyflow) loop_t $-      mkUsage (srclocOf loopbody') "being (part of) the result of the loop body"--  let consumeMerge (Id _ (Info pt) ploc) mt-        | unique pt = consume ploc $ aliases mt-      consumeMerge (TuplePattern pats _) t | Just ts <- isTupleRecord t =-        zipWithM_ consumeMerge pats ts-      consumeMerge (PatternParens pat _) t =-        consumeMerge pat t-      consumeMerge (PatternAscription pat _ _) t =-        consumeMerge pat t-      consumeMerge _ _ =-        return ()-  consumeMerge mergepat'' =<< expType mergeexp'-  return $ DoLoop mergepat'' mergeexp' form' loopbody' loc--  where-    convergePattern pat body_cons body_t body_loc = do-      let consumed_merge = S.map identName (patternIdents pat) `S.intersection`-                           body_cons--          uniquePat (Wildcard (Info t) wloc) =-            Wildcard (Info $ t `setUniqueness` Nonunique) wloc-          uniquePat (PatternParens p ploc) =-            PatternParens (uniquePat p) ploc-          uniquePat (Id name (Info t) iloc)-            | name `S.member` consumed_merge =-                let t' = t `setUniqueness` Unique `setAliases` mempty-                in Id name (Info t') iloc-            | otherwise =-                let t' = case t of Scalar Record{} -> t-                                   _               -> t `setUniqueness` Nonunique-                in Id name (Info t') iloc-          uniquePat (TuplePattern pats ploc) =-            TuplePattern (map uniquePat pats) ploc-          uniquePat (RecordPattern fs ploc) =-            RecordPattern (map (fmap uniquePat) fs) ploc-          uniquePat (PatternAscription p t ploc) =-            PatternAscription p t ploc-          uniquePat p@PatternLit{} = p-          uniquePat (PatternConstr n t ps ploc) =-            PatternConstr n t (map uniquePat ps) ploc--          -- Make the pattern unique where needed.-          pat' = uniquePat pat--      -- Now check that the loop returned the right type.-      unify body_loc (toStructural body_t) $ toStructural $ patternType pat'-      body_t' <- normaliseType body_t-      pat_t <- normaliseType $ patternType pat'-      unless (body_t' `subtypeOf` pat_t) $-        unexpectedType (srclocOf body_loc)-        (toStructural body_t')-        [toStructural pat_t]--      -- Check that the new values of consumed merge parameters do not-      -- alias something bound outside the loop, AND that anything-      -- returned for a unique merge parameter does not alias anything-      -- else returned.  We also update the aliases for the pattern.-      bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope-      let combAliases t1 t2 =-            case t1 of Scalar Record{} -> t1-                       _ -> t1 `addAliases` (<>aliases t2)--          checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t-            | unique pat_v_t,-              v:_ <- S.toList $-                     S.map aliasVar (aliases t) `S.intersection` bound_outside =-                lift $ typeError loc $-                "Loop return value corresponding to merge parameter " ++-                quote (prettyName pat_v) ++ " aliases " ++ prettyName v ++ "."--            | otherwise = do-                (cons,obs) <- get-                unless (S.null $ aliases t `S.intersection` cons) $-                  lift $ typeError loc $-                  "Loop return value for merge parameter " ++-                  quote (prettyName pat_v) ++-                  " aliases other consumed merge parameter."-                when (unique pat_v_t &&-                      not (S.null (aliases t `S.intersection` (cons<>obs)))) $-                  lift $ typeError loc $-                  "Loop return value for consuming merge parameter " ++-                  quote (prettyName pat_v) ++ " aliases previously returned value."-                if unique pat_v_t-                  then put (cons<>aliases t, obs)-                  else put (cons, obs<>aliases t)--                return $ Id pat_v (Info (combAliases pat_v_t t)) patloc--          checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =-            return $ Wildcard (Info (combAliases pat_v_t t)) patloc--          checkMergeReturn (PatternParens p _) t =-            checkMergeReturn p t--          checkMergeReturn (PatternAscription p _ _) t =-            checkMergeReturn p t--          checkMergeReturn (RecordPattern pfs patloc) (Scalar (Record tfs)) =-            RecordPattern . M.toList <$> sequence pfs' <*> pure patloc-            where pfs' = M.intersectionWith checkMergeReturn-                         (M.fromList pfs) tfs--          checkMergeReturn (TuplePattern pats patloc) t-            | Just ts <- isTupleRecord t =-                TuplePattern-                <$> zipWithM checkMergeReturn pats ts-                <*> pure patloc--          checkMergeReturn p _ =-            return p--      (pat'', (pat_cons, _)) <--        runStateT (checkMergeReturn pat' body_t') (mempty, mempty)--      let body_cons' = body_cons <> S.map aliasVar pat_cons-      if body_cons' == body_cons && patternType pat'' == patternType pat-        then return pat'-        else convergePattern pat'' body_cons' body_t' body_loc--checkExp (Constr name es NoInfo loc) = do-  t <- newTypeVar loc "t"-  es' <- mapM checkExp es-  ets <- mapM expType es'-  mustHaveConstr (mkUsage loc "use of constructor") name t (toStructural <$> ets)-  -- A sum value aliases *anything* that went into its construction.-  let als = mconcat (map aliases ets)-  return $ Constr name es' (Info $ t `addAliases` (<>als)) loc--checkExp (Match e cs NoInfo loc) =-  sequentially (checkExp e) $ \e' _ -> do-    mt <- expType e'-    (cs', t) <- checkCases mt cs-    zeroOrderType (mkUsage loc "being returned 'match'") "returned from pattern match" t-    return $ Match e' cs' (Info t) loc--checkCases :: PatternType-           -> NE.NonEmpty (CaseBase NoInfo Name)-           -> TermTypeM (NE.NonEmpty (CaseBase Info VName), PatternType)-checkCases mt rest_cs =-  case NE.uncons rest_cs of-    (c, Nothing) -> do-      (c', t) <- checkCase mt c-      return (c' NE.:| [], t)-    (c, Just cs) -> do-      (((c', c_t), (cs', cs_t)), dflow) <--        tapOccurences $ checkCase mt c `alternative` checkCases mt cs-      unify (mkUsage (srclocOf c) "pattern match") (toStructural c_t) (toStructural cs_t)-      let t = unifyTypeAliases c_t cs_t `addAliases`-              (`S.difference` S.map AliasBound (allConsumed dflow))-      return (NE.cons c' cs', t)--checkCase :: PatternType -> CaseBase NoInfo Name-          -> TermTypeM (CaseBase Info VName, PatternType)-checkCase mt (CasePat p caseExp loc) =-  bindingPattern p (Ascribed mt) $ \p' -> do-    caseExp' <- checkExp caseExp-    caseType <- expType caseExp'-    return (CasePat p' caseExp' loc, caseType)---- | An unmatched pattern. Used in in the generation of--- unmatched pattern warnings by the type checker.-data Unmatched p = UnmatchedNum p [ExpBase Info VName]-                 | UnmatchedBool p-                 | UnmatchedConstr p-                 | Unmatched p-                 deriving (Functor, Show)--instance Pretty (Unmatched (PatternBase Info VName)) where-  ppr um = case um of-      (UnmatchedNum p nums) -> ppr' p <+> text "where p is not one of" <+> ppr nums-      (UnmatchedBool p)     -> ppr' p-      (UnmatchedConstr p)     -> ppr' p-      (Unmatched p)         -> ppr' p-    where-      ppr' (PatternAscription p t _) = ppr p <> text ":" <+> ppr t-      ppr' (PatternParens p _)       = parens $ ppr' p-      ppr' (Id v _ _)                = pprName v-      ppr' (TuplePattern pats _)     = parens $ commasep $ map ppr' pats-      ppr' (RecordPattern fs _)      = braces $ commasep $ map ppField fs-        where ppField (name, t)      = text (nameToString name) <> equals <> ppr' t-      ppr' Wildcard{}                = text "_"-      ppr' (PatternLit e _ _)        = ppr e-      ppr' (PatternConstr n _ ps _)   = text "#" <> ppr n <+> sep (map ppr' ps)--unpackPat :: Pattern -> [Maybe Pattern]-unpackPat Wildcard{} = [Nothing]-unpackPat (PatternParens p _) = unpackPat p-unpackPat Id{} = [Nothing]-unpackPat (TuplePattern ps _) = Just <$> ps-unpackPat (RecordPattern fs _) = Just . snd <$> sortFields (M.fromList fs)-unpackPat (PatternAscription p _ _) = unpackPat p-unpackPat p@PatternLit{} = [Just p]-unpackPat p@PatternConstr{} = [Just p]--wildPattern :: Pattern -> Int -> Unmatched Pattern -> Unmatched Pattern-wildPattern (TuplePattern ps loc) pos um = wildTuple <$> um-  where wildTuple p = TuplePattern (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc-        ps' = map wildOut ps-        wildOut p = Wildcard (Info (patternType p)) (srclocOf p)-wildPattern (RecordPattern fs loc) pos um = wildRecord <$> um-  where wildRecord p =-          RecordPattern (take (pos - 1) fs' ++ [(fst (fs!!(pos - 1)), p)] ++ drop pos fs') loc-        fs' = map wildOut fs-        wildOut (f,p) = (f, Wildcard (Info (patternType p)) (srclocOf p))-wildPattern (PatternAscription p _ _) pos um = wildPattern p pos um-wildPattern (PatternParens p _) pos um = wildPattern p pos um-wildPattern (PatternConstr n t ps loc) pos um = wildConstr <$> um-  where wildConstr p = PatternConstr n t (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc-        ps' = map wildOut ps-        wildOut p = Wildcard (Info (patternType p)) (srclocOf p)-wildPattern _ _ um = um--checkUnmatched :: (MonadBreadCrumbs m, MonadTypeChecker m) => Exp -> m ()-checkUnmatched e = void $ checkUnmatched' e >> astMap tv e-  where checkUnmatched' (Match _ cs _ loc) =-          let ps = fmap (\(CasePat p _ _) -> p) cs-          in case unmatched id $ NE.toList ps of-              []  -> return ()-              ps' -> typeError loc $ "Unmatched cases in match expression: \n"-                                     ++ unlines (map (("  " ++) . pretty) ps')-        checkUnmatched' _ = return ()-        tv = ASTMapper { mapOnExp =-                           \e' -> checkUnmatched' e' >> return e'-                       , mapOnName        = pure-                       , mapOnQualName    = pure-                       , mapOnStructType  = pure-                       , mapOnPatternType = pure-                       }---- | A data type for constructor patterns.  This is used to make the--- code for detecting unmatched constructors cleaner, by separating--- the constructor-pattern cases from other cases.-data ConstrPat = ConstrPat { constrName :: Name-                           , constrType :: PatternType-                           , constrPayload :: [Pattern]-                           , constrSrcLoc :: SrcLoc-                           }---- Be aware of these fishy equality instances!--instance Eq ConstrPat where-  ConstrPat c1 _ _ _ == ConstrPat c2 _ _ _ = c1 == c2--instance Ord ConstrPat where-  ConstrPat c1 _ _ _ `compare` ConstrPat c2 _ _ _ = c1 `compare` c2--unmatched :: (Unmatched Pattern -> Unmatched Pattern) -> [Pattern] -> [Unmatched Pattern]-unmatched hole orig_ps-  | p:_ <- orig_ps,-    sameStructure labeledCols = do-    (i, cols) <- labeledCols-    let hole' = if isConstr p then hole else hole . wildPattern p i-    case sequence cols of-      Nothing -> []-      Just cs-        | all isPatternLit cs  -> map hole' $ localUnmatched cs-        | otherwise            -> unmatched hole' cs-  | otherwise = []--  where labeledCols = zip [1..] $ transpose $ map unpackPat orig_ps--        localUnmatched :: [Pattern] -> [Unmatched Pattern]-        localUnmatched [] = []-        localUnmatched ps'@(p':_) =-          case patternType p'  of-            Scalar (Sum cs'') ->-              -- We now know that we are matching a sum type, and thus-              -- that all patterns ps' are constructors (checked by-              -- 'all isPatternLit' before this function is called).-              let constrs   = M.keys cs''-                  matched   = mapMaybe constr ps'-                  unmatched' = map (UnmatchedConstr . buildConstr cs'') $-                               constrs \\ map constrName matched-             in case unmatched' of-                [] ->-                  let constrGroups   = group (sort matched)-                      removedConstrs = mapMaybe stripConstrs constrGroups-                      transposed     = (fmap . fmap) transpose removedConstrs-                      findUnmatched (pc, trans) = do-                        col <- trans-                        case col of-                          []           -> []-                          ((i, _):_) -> unmatched (wilder i pc) (map snd col)-                      wilder i pc s = (`PatternParens` noLoc) <$> wildPattern pc i s-                  in concatMap findUnmatched transposed-                _ -> unmatched'-            Scalar (Prim t) | not (any idOrWild ps') ->-              -- We now know that we are matching a sum type, and thus-              -- that all patterns ps' are literals (checked by 'all-              -- isPatternLit' before this function is called).-                case t of-                  Bool ->-                    let matched = nub $ mapMaybe (pExp >=> bool) $ filter isPatternLit ps'-                    in map (UnmatchedBool . buildBool (Scalar (Prim t))) $ [True, False] \\ matched-                  _ ->-                    let matched = mapMaybe pExp $ filter isPatternLit ps'-                    in [UnmatchedNum (buildId (Info $ Scalar $ Prim t) "p") matched]-            _ -> []--        isConstr PatternConstr{} = True-        isConstr (PatternParens p _) = isConstr p-        isConstr _ = False---        stripConstrs :: [ConstrPat] -> Maybe (Pattern, [[(Int, Pattern)]])-        stripConstrs (pc@ConstrPat{} : cs') = Just (unConstr pc, stripConstr pc : map stripConstr cs')-        stripConstrs [] = Nothing--        stripConstr :: ConstrPat -> [(Int, Pattern)]-        stripConstr (ConstrPat _ _  ps' _) = zip [1..] ps'--        sameStructure [] = True-        sameStructure (x:xs) = all (\y -> length y == length x' ) xs'-          where (x':xs') = map snd (x:xs)--        pExp (PatternLit e' _ _) = Just e'-        pExp _ = Nothing--        constr (PatternConstr c (Info t) ps loc) = Just $ ConstrPat c t ps loc-        constr (PatternParens p _) = constr p-        constr (PatternAscription p' _ _)  = constr p'-        constr _ = Nothing--        unConstr p =-          PatternConstr (constrName p) (Info $ constrType p) (constrPayload p) (constrSrcLoc p)--        isPatternLit PatternLit{} = True-        isPatternLit (PatternAscription p' _ _) = isPatternLit p'-        isPatternLit (PatternParens p' _)  = isPatternLit p'-        isPatternLit PatternConstr{} = True-        isPatternLit _ = False--        idOrWild Id{} = True-        idOrWild Wildcard{} = True-        idOrWild (PatternAscription p' _ _) = idOrWild p'-        idOrWild (PatternParens p' _) = idOrWild p'-        idOrWild _ = False--        bool (Literal (BoolValue b) _ ) = Just b-        bool _ = Nothing--        buildConstr m c =-          let t      = Scalar $ Sum m-              cs     = m M.! c-              wildCS = map (\ct -> Wildcard (Info ct) noLoc) cs-          in if null wildCS-               then PatternConstr c (Info t) [] noLoc-               else PatternParens (PatternConstr c (Info t) wildCS noLoc) noLoc-        buildBool t b =-          PatternLit (Literal (BoolValue b) noLoc) (Info (vacuousShapeAnnotations t)) noLoc-        buildId t n =-          -- The VName tag here will never be used since the value-          -- exists exclusively for printing warnings.-          Id (VName (nameFromString n) (-1)) t noLoc--checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident-checkIdent (Ident name _ loc) = do-  (QualName _ name', vt) <- lookupVar loc (qualName name)-  return $ Ident name' (Info vt) loc--checkDimIndex :: DimIndexBase NoInfo Name -> TermTypeM DimIndex-checkDimIndex (DimFix i) =-  DimFix <$> (unifies "use as index" (Scalar $ Prim $ Signed Int32) =<< checkExp i)-checkDimIndex (DimSlice i j s) =-  DimSlice <$> check i <*> check j <*> check s-  where check = maybe (return Nothing) $-                fmap Just . unifies "use as index" (Scalar $ Prim $ Signed Int32) <=< checkExp--sequentially :: TermTypeM a -> (a -> Occurences -> TermTypeM b) -> TermTypeM b-sequentially m1 m2 = do-  (a, m1flow) <- collectOccurences m1-  (b, m2flow) <- collectOccurences $ m2 a m1flow-  occur $ m1flow `seqOccurences` m2flow-  return b--type Arg = (PatternType, Occurences, SrcLoc)--argType :: Arg -> PatternType-argType (t, _, _) = t--checkArg :: UncheckedExp -> TermTypeM (Exp, Arg)-checkArg arg = do-  (arg', dflow) <- collectOccurences $ checkExp arg-  arg_t <- expType arg'-  return (arg', (arg_t, dflow, srclocOf arg'))--checkApply :: SrcLoc -> PatternType -> Arg-           -> TermTypeM (PatternType, PatternType)-checkApply loc (Scalar (Arrow as _ tp1 tp2)) (argtype, dflow, argloc) = do-  unify (mkUsage argloc "use as function argument") (toStructural tp1) (toStructural argtype)--  -- Perform substitutions of instantiated variables in the types.-  tp1' <- normaliseType tp1-  tp2' <- normaliseType tp2-  argtype' <- normaliseType argtype--  occur [observation as loc]--  checkOccurences dflow-  occurs <- consumeArg argloc argtype' (diet tp1')--  case anyConsumption dflow of-    Just c ->-      let msg = "of value computed with consumption at " ++ locStr (location c)-      in zeroOrderType (mkUsage argloc "potential consumption in expression") msg tp1-    _ -> return ()--  occur $ dflow `seqOccurences` occurs-  let tp2'' = anyDimShapeAnnotations $ returnType tp2' (diet tp1') argtype'-  return (tp1', tp2'')--checkApply loc tfun@(Scalar TypeVar{}) arg = do-  tv <- newTypeVar loc "b"-  unify (mkUsage loc "use as function") (toStructural tfun) $-    Scalar $ Arrow mempty Unnamed (toStructural (argType arg)) tv-  constraints <- getConstraints-  checkApply loc (applySubst (`lookupSubst` constraints) tfun) arg--checkApply loc ftype arg =-  typeError loc $-  "Attempt to apply an expression of type " ++ pretty ftype ++-  " to an argument of type " ++ pretty (argType arg) ++ "."---- | @returnType ret_type arg_diet arg_type@ gives result of applying--- an argument the given types to a function with the given return--- type, consuming the argument with the given diet.-returnType :: PatternType-           -> Diet-           -> PatternType-           -> PatternType-returnType (Array _ Unique et shape) _ _ =-  Array mempty Unique et shape-returnType (Array als Nonunique et shape) d arg =-  Array (als<>arg_als) Unique et shape -- Intentional!-  where arg_als = aliases $ maskAliases arg d-returnType (Scalar (Record fs)) d arg =-  Scalar $ Record $ fmap (\et -> returnType et d arg) fs-returnType (Scalar (Prim t)) _ _ =-  Scalar $ Prim t-returnType (Scalar (TypeVar _ Unique t targs)) _ _ =-  Scalar $ TypeVar mempty Unique t targs-returnType (Scalar (TypeVar als Nonunique t targs)) d arg =-  Scalar $ TypeVar (als<>arg_als) Unique t targs -- Intentional!-  where arg_als = aliases $ maskAliases arg d-returnType (Scalar (Arrow _ v t1 t2)) d arg =-  Scalar $ Arrow als v (t1 `setAliases` mempty) (t2 `setAliases` als)-  where als = aliases $ maskAliases arg d-returnType (Scalar (Sum cs)) d arg =-  Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs---- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from--- the parts of @t@ that are denoted as consumed by the 'Diet' @d@.-maskAliases :: Monoid as =>-               TypeBase shape as-            -> Diet-            -> TypeBase shape as-maskAliases t Consume = t `setAliases` mempty-maskAliases t Observe = t-maskAliases (Scalar (Record ets)) (RecordDiet ds) =-  Scalar $ Record $ M.intersectionWith maskAliases ets ds-maskAliases t FuncDiet{} = t-maskAliases _ _ = error "Invalid arguments passed to maskAliases."--consumeArg :: SrcLoc -> PatternType -> Diet -> TermTypeM [Occurence]-consumeArg loc (Scalar (Record ets)) (RecordDiet ds) =-  concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds)-consumeArg loc (Array _ Nonunique _ _) Consume =-  typeError loc "Consuming parameter passed non-unique argument."-consumeArg loc (Scalar (Arrow _ _ t1 _)) (FuncDiet d _)-  | not $ contravariantArg t1 d =-      typeError loc "Non-consuming higher-order parameter passed consuming argument."-  where contravariantArg (Array _ Unique _ _) Observe =-          False-        contravariantArg (Scalar (TypeVar _ Unique _ _)) Observe =-          False-        contravariantArg (Scalar (Record ets)) (RecordDiet ds) =-          and (M.intersectionWith contravariantArg ets ds)-        contravariantArg (Scalar (Arrow _ _ tp tr)) (FuncDiet dp dr) =-          contravariantArg tp dp && contravariantArg tr dr-        contravariantArg _ _ =-          True-consumeArg loc (Scalar (Arrow _ _ _ t2)) (FuncDiet _ pd) =-  consumeArg loc t2 pd-consumeArg loc at Consume = return [consumption (aliases at) loc]-consumeArg loc at _       = return [observation (aliases at) loc]--checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)-checkOneExp e = fmap fst . runTermTypeM $ do-  e' <- checkExp e-  let t = toStruct $ typeOf e'-  tparams <- letGeneralise [] t-  fixOverloadedTypes-  e'' <- updateExpTypes e'-  return (tparams, e'')---- | Type-check a top-level (or module-level) function definition.--- Despite the name, this is also used for checking constant--- definitions, by treating them as 0-ary functions.-checkFunDef :: (Name, Maybe UncheckedTypeExp,-                [UncheckedTypeParam], [UncheckedPattern],-                UncheckedExp, SrcLoc)-            -> TypeM (VName, [TypeParam], [Pattern], Maybe (TypeExp VName), StructType, Exp)-checkFunDef (fname, maybe_retdecl, tparams, params, body, loc) =-  fmap fst $ runTermTypeM $ do-  (tparams', params', maybe_retdecl', rettype', body') <--    checkBinding (Just fname, maybe_retdecl, tparams, params, body, loc)--  -- Since this is a top-level function, we also resolve overloaded-  -- types, using either defaults or complaining about ambiguities.-  fixOverloadedTypes--  -- Then replace all inferred types in the body and parameters.-  body'' <- updateExpTypes body'-  params'' <- updateExpTypes params'-  maybe_retdecl'' <- traverse updateExpTypes maybe_retdecl'-  rettype'' <- normaliseType rettype'--  -- Check if pattern matches are exhaustive and yield-  -- errors if not.-  checkUnmatched body''--  bindSpaced [(Term, fname)] $ do-    fname' <- checkName Term fname loc-    when (nameToString fname `elem` doNotShadow) $-      typeError loc $ "The " ++ nameToString fname ++ " operator may not be redefined."--    return (fname', tparams', params'', maybe_retdecl'', rettype'', body'')---- | This is "fixing" as in "setting them", not "correcting them".  We--- only make very conservative fixing.-fixOverloadedTypes :: TermTypeM ()-fixOverloadedTypes = getConstraints >>= mapM_ fixOverloaded . M.toList . M.map snd-  where fixOverloaded (v, Overloaded ots usage)-          | Signed Int32 `elem` ots = do-              unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $-                Scalar $ Prim $ Signed Int32-              warn usage "Defaulting ambiguous type to `i32`."-          | FloatType Float64 `elem` ots = do-              unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $-                Scalar $ Prim $ FloatType Float64-              warn usage "Defaulting ambiguous type to `f64`."-          | otherwise =-              typeError usage $-              unlines ["Type is ambiguous (could be one of " ++ intercalate ", " (map pretty ots) ++ ").",-                       "Add a type annotation to disambiguate the type."]--        fixOverloaded (_, NoConstraint _ usage) =-          typeError usage $ unlines ["Type of expression is ambiguous.",-                                     "Add a type annotation to disambiguate the type."]--        fixOverloaded (_, Equality usage) =-          typeError usage $ unlines ["Type is ambiguous (must be equality type).",-                                     "Add a type annotation to disambiguate the type."]--        fixOverloaded (_, HasFields fs usage) =-          typeError usage $ unlines ["Type is ambiguous.  Must be record with fields:",-                                     unlines $ map field $ M.toList fs,-                                     "Add a type annotation to disambiguate the type."]-          where field (l, t) = pretty $ indent 2 $ ppr l <> colon <+> align (ppr t)--        fixOverloaded (_, HasConstrs cs usage) =-          typeError usage $ unlines [ "Type is ambiguous (must be a sum type with constructors: " ++-                                      pretty (Sum cs) ++ ")."-                                    , "Add a type annotation to disambiguate the type."]--        fixOverloaded _ = return ()--checkBinding :: (Maybe Name, Maybe UncheckedTypeExp,-                 [UncheckedTypeParam], [UncheckedPattern],-                 UncheckedExp, SrcLoc)-             -> TermTypeM ([TypeParam], [Pattern], Maybe (TypeExp VName), StructType, Exp)-checkBinding (fname, maybe_retdecl, tparams, params, body, loc) =-  noUnique $ incLevel $ bindingPatternGroup tparams params $ \tparams' params' -> do-    maybe_retdecl' <- traverse checkTypeExp maybe_retdecl--    body' <- checkFunBody body ((\(_,t,_)->t) <$> maybe_retdecl') (maybe loc srclocOf maybe_retdecl)--    params'' <- updateExpTypes params'-    body_t <- expType body'--    (maybe_retdecl'', rettype) <- case maybe_retdecl' of-      Just (retdecl', retdecl_type, _) -> do-        let rettype_structural = toStructural retdecl_type-        checkReturnAlias rettype_structural params'' body_t--        when (null params) $ nothingMustBeUnique loc rettype_structural--        warnOnDubiousShapeAnnotations loc params'' retdecl_type--        return (Just retdecl', retdecl_type)-      Nothing-        | null params ->-            return (Nothing, toStruct $ body_t `setUniqueness` Nonunique)-        | otherwise ->-            return (Nothing, inferReturnUniqueness params'' body_t)--    let fun_t = foldFunType (map patternStructType params'') rettype-    tparams'' <- letGeneralise tparams' fun_t--    checkGlobalAliases params'' body_t loc--    return (tparams'', params'', maybe_retdecl'', rettype, body')--  where -- | Check that unique return values do not alias a-        -- non-consumed parameter.-        checkReturnAlias rettp params' =-          foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp-        checkReturnAlias' params' seen (Unique, names)-          | any (`S.member` S.map snd seen) $ S.toList names =-              uniqueReturnAliased fname loc-          | otherwise = do-              notAliasingParam params' names-              return $ seen `S.union` tag Unique names-        checkReturnAlias' _ seen (Nonunique, names)-          | any (`S.member` seen) $ S.toList $ tag Unique names =-            uniqueReturnAliased fname loc-          | otherwise = return $ seen `S.union` tag Nonunique names--        notAliasingParam params' names =-          forM_ params' $ \p ->-          let consumedNonunique p' =-                not (unique $ unInfo $ identType p') && (identName p' `S.member` names)-          in case find consumedNonunique $ S.toList $ patternIdents p of-               Just p' ->-                 returnAliased fname (baseName $ identName p') loc-               Nothing ->-                 return ()--        tag u = S.map (u,)--        returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =-          concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2-        returnAliasing expected got =-          [(uniqueness expected, S.map aliasVar $ aliases got)]--warnOnDubiousShapeAnnotations :: SrcLoc -> [Pattern] -> StructType -> TermTypeM ()-warnOnDubiousShapeAnnotations loc params rettype =-  onDubiousNames $ S.filter patternNameButNotParamName $-  mconcat $ map typeDimNames $-  rettype : map patternStructType params-  where named (Named v) = Just v-        named Unnamed = Nothing-        param_names = S.fromList $ mapMaybe (named . fst . patternParam) params-        all_pattern_names = S.map identName $ mconcat $ map patternIdents params-        patternNameButNotParamName v = v `S.member` all_pattern_names && not (v `S.member` param_names)-        onDubiousNames dubious-          | S.null dubious = return ()-          | otherwise = warn loc $ unlines-                        [ "Size annotations in parameter and/or return type refers to the following names,"-                        , "which will not be visible to the caller, because they are nested in tuples or records:"-                        , "  " ++ intercalate ", " (map (quote . prettyName) $ S.toList dubious)-                        , "To eliminate this warning, make these names parameters on their own."]--checkGlobalAliases :: [Pattern] -> PatternType -> SrcLoc -> TermTypeM ()-checkGlobalAliases params body_t loc = do-  vtable <- asks $ scopeVtable . termScope-  let isLocal v = case v `M.lookup` vtable of-                    Just (BoundV Local _ _) -> True-                    _ -> False-  let als = filter (not . isLocal) $ S.toList $-            boundArrayAliases body_t `S.difference`-            S.map identName (mconcat (map patternIdents params))-  case als of-    v:_ | not $ null params ->-      typeError loc $-      unlines [ "Function result aliases the free variable " <>-                quote (prettyName v) <> "."-              , "Use " ++ quote "copy" ++ " to break the aliasing."]-    _ ->-      return ()---inferReturnUniqueness :: [Pattern] -> PatternType -> StructType-inferReturnUniqueness params t =-  let forbidden = aliasesMultipleTimes t-      uniques = uniqueParamNames params-      delve (Scalar (Record fs)) =-        Scalar $ Record $ M.map delve fs-      delve t'-        | all (`S.member` uniques) (boundArrayAliases t'),-          not $ any ((`S.member` forbidden) . aliasVar) (aliases t') =-            toStruct t'-        | otherwise =-            toStruct $ t' `setUniqueness` Nonunique-  in delve t---- An alias inhibits uniqueness if it is used in disjoint values.-aliasesMultipleTimes :: PatternType -> Names-aliasesMultipleTimes = S.fromList . map fst . filter ((>1) . snd) . M.toList . delve-  where delve (Scalar (Record fs)) =-          foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs-        delve t =-          M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1::Int)--uniqueParamNames :: [Pattern] -> Names-uniqueParamNames =-  S.fromList . map identName-  . filter (unique . unInfo . identType)-  . S.toList . mconcat . map patternIdents--boundArrayAliases :: PatternType -> S.Set VName-boundArrayAliases (Array als _ _ _) = boundAliases als-boundArrayAliases (Scalar Prim{}) = mempty-boundArrayAliases (Scalar (Record fs)) = foldMap boundArrayAliases fs-boundArrayAliases (Scalar (TypeVar als _ _ _)) = boundAliases als-boundArrayAliases (Scalar Arrow{}) = mempty-boundArrayAliases (Scalar (Sum fs)) =-  mconcat $ concatMap (map boundArrayAliases) $ M.elems fs---- | The set of in-scope variables that are being aliased.-boundAliases :: Aliasing -> S.Set VName-boundAliases = S.map aliasVar . S.filter bound-  where bound AliasBound{} = True-        bound AliasFree{} = False--nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()-nothingMustBeUnique loc = check-  where check (Array _ Unique _ _) = bad-        check (Scalar (TypeVar _ Unique _ _)) = bad-        check (Scalar (Record fs)) = mapM_ check fs-        check _ = return ()-        bad = typeError loc "A top-level constant cannot have a unique type."--letGeneralise :: [TypeParam] -> StructType -> TermTypeM [TypeParam]-letGeneralise tparams t = do-  now_substs <- getConstraints-  -- Candidates for let-generalisation are those type variables that-  ---  -- (1) were not known before we checked this function, and-  ---  -- (2) are not used in the (new) definition of any type variables-  -- known before we checked this function.-  ---  -- (3) are not referenced from an overloaded type (for example,-  -- are the element types of an incompletely resolved record type).-  -- This is a bit more restrictive than I'd like, and SML for-  -- example does not have this restriction.-  ---  -- Criteria (1) and (2) is implemented by looking at the binding-  -- level of the type variables.-  let keep_type_vars = overloadedTypeVars now_substs--  cur_lvl <- curLevel-  let candiate k (lvl, _) = (k `S.notMember` keep_type_vars) && lvl >= cur_lvl-      new_substs = M.filterWithKey candiate now_substs-  tparams' <- closeOverTypes new_substs tparams t--  -- We keep those type variables that were not closed over by-  -- let-generalisation.-  modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams'--  return tparams'--checkFunBody :: ExpBase NoInfo Name-             -> Maybe StructType-             -> SrcLoc-             -> TermTypeM Exp-checkFunBody body maybe_rettype _loc = do-  body' <- checkExp body--  -- Unify body return type with return annotation, if one exists.-  case maybe_rettype of-    Just rettype -> do-      let rettype_structural = toStructural rettype-      void $ unifies "return type annotation" rettype_structural body'-      -- We also have to make sure that uniqueness matches.  This is done-      -- explicitly, because uniqueness is ignored by unification.-      rettype' <- normaliseType rettype-      body_t <- expType body'-      unless (body_t `subtypeOf` anyDimShapeAnnotations rettype') $-        typeError (srclocOf body) $ "Body type " ++ quote (pretty body_t) ++-        " is not a subtype of annotated type " ++-        quote (pretty rettype') ++ "."--    Nothing -> return ()--  return body'---- | Find at all type variables in the given type that are covered by--- the constraints, and produce type parameters that close over them.------ The passed-in list of type parameters is always prepended to the--- produced list of type parameters.-closeOverTypes :: Constraints -> [TypeParam] -> StructType -> TermTypeM [TypeParam]-closeOverTypes substs tparams t =-  fmap ((tparams++) . catMaybes) $ mapM closeOver $ M.toList $ M.map snd to_close_over-  where to_close_over = M.filterWithKey (\k _ -> k `S.member` visible) substs-        visible = typeVars t--        -- Avoid duplicate type parameters.-        closeOver (k, _)-          | k `elem` map typeParamName tparams =-              return Nothing-        closeOver (k, NoConstraint Unlifted usage) =-          return $ Just $ TypeParamType Unlifted k $ srclocOf usage-        closeOver (k, NoConstraint _ usage) =-          return $ Just $ TypeParamType Lifted k $ srclocOf usage-        closeOver (k, ParamType l loc) =-          return $ Just $ TypeParamType l k loc-        closeOver (_, _) =-          return Nothing----- Consumption--occur :: Occurences -> TermTypeM ()-occur = tell---- | Proclaim that we have made read-only use of the given variable.-observe :: Ident -> TermTypeM ()-observe (Ident nm (Info t) loc) =-  let als = AliasBound nm `S.insert` aliases t-  in occur [observation als loc]---- | Proclaim that we have written to the given variable.-consume :: SrcLoc -> Aliasing -> TermTypeM ()-consume loc als = do-  vtable <- asks $ scopeVtable . termScope-  let consumable v = case M.lookup v vtable of-                       Just (BoundV Local _ t)-                         | arrayRank t > 0 -> unique t-                         | otherwise -> True-                       _ -> False-  case filter (not . consumable) $ map aliasVar $ S.toList als of-    v:_ -> typeError loc $ "Attempt to consume variable " ++ quote (prettyName v)-           ++ ", which is not allowed."-    [] -> occur [consumption als loc]---- | Proclaim that we have written to the given variable, and mark--- accesses to it and all of its aliases as invalid inside the given--- computation.-consuming :: Ident -> TermTypeM a -> TermTypeM a-consuming (Ident name (Info t) loc) m = do-  consume loc $ AliasBound name `S.insert` aliases t-  localScope consume' m-  where consume' scope =-          scope { scopeVtable = M.insert name (WasConsumed loc) $ scopeVtable scope }--collectOccurences :: TermTypeM a -> TermTypeM (a, Occurences)-collectOccurences m = pass $ do-  (x, dataflow) <- listen m-  return ((x, dataflow), const mempty)--tapOccurences :: TermTypeM a -> TermTypeM (a, Occurences)-tapOccurences = listen--removeSeminullOccurences :: TermTypeM a -> TermTypeM a-removeSeminullOccurences = censor $ filter $ not . seminullOccurence--checkIfUsed :: Occurences -> Ident -> TermTypeM ()-checkIfUsed occs v-  | not $ identName v `S.member` allOccuring occs,-    not $ "_" `isPrefixOf` prettyName (identName v) =-      warn (srclocOf v) $ "Unused variable " ++ quote (pretty $ baseName $ identName v) ++ "."-  | otherwise =-      return ()--alternative :: TermTypeM a -> TermTypeM b -> TermTypeM (a,b)-alternative m1 m2 = pass $ do-  (x, occurs1) <- listen m1-  (y, occurs2) <- listen m2-  checkOccurences occurs1-  checkOccurences occurs2-  let usage = occurs1 `altOccurences` occurs2-  return ((x, y), const usage)---- | Make all bindings nonunique.-noUnique :: TermTypeM a -> TermTypeM a-noUnique = localScope (\scope -> scope { scopeVtable = M.map set $ scopeVtable scope})-  where set (BoundV l tparams t)    = BoundV l tparams $ t `setUniqueness` Nonunique-        set (OverloadedF ts pts rt) = OverloadedF ts pts rt-        set EqualityF               = EqualityF-        set (WasConsumed loc)       = WasConsumed loc--onlySelfAliasing :: TermTypeM a -> TermTypeM a-onlySelfAliasing = localScope (\scope -> scope { scopeVtable = M.mapWithKey set $ scopeVtable scope})-  where set k (BoundV l tparams t)    = BoundV l tparams $-                                        t `addAliases` S.intersection (S.singleton (AliasBound k))-        set _ (OverloadedF ts pts rt) = OverloadedF ts pts rt-        set _ EqualityF               = EqualityF-        set _ (WasConsumed loc)       = WasConsumed loc--arrayOfM :: (Pretty (ShapeDecl dim), Monoid as) =>-            SrcLoc-         -> TypeBase dim as -> ShapeDecl dim -> Uniqueness-         -> TermTypeM (TypeBase dim as)-arrayOfM loc t shape u = do-  zeroOrderType (mkUsage loc "use as array element") "used in array" t-  return $ arrayOf t shape u---- | Perform substitutions of instantiated variables on the type--- annotations (including the instance lists) of an expression, or--- something else.-updateExpTypes :: ASTMappable e => e -> TermTypeM e-updateExpTypes e = do-  constraints <- getConstraints-  let look = (`lookupSubst` constraints)-      tv = ASTMapper { mapOnExp         = astMap tv-                     , mapOnName        = pure-                     , mapOnQualName    = pure-                     , mapOnStructType  = pure . applySubst look-                     , mapOnPatternType = pure . applySubst look-                     }-  astMap tv e+{-# Language OverloadedStrings #-}+-- | Facilities for type-checking Futhark terms.  Checking a term+-- requires a little more context to track uniqueness and such.+--+-- Type inference is implemented through a variation of+-- Hindley-Milner.  The main complication is supporting the rich+-- number of built-in language constructs, as well as uniqueness+-- types.  This is mostly done in an ad hoc way, and many programs+-- will require the programmer to fall back on type annotations.+module Language.Futhark.TypeChecker.Terms+  ( checkOneExp+  , checkFunDef+  )+where++import Control.Monad.Identity+import Control.Monad.Except+import Control.Monad.State+import Control.Monad.RWS hiding (Sum)+import Control.Monad.Writer hiding (Sum)+import Data.Bifunctor+import Data.Char (isAscii)+import Data.Either+import Data.List+import qualified Data.List.NonEmpty as NE+import Data.Loc+import Data.Maybe+import qualified Data.Map.Strict as M+import qualified Data.Set as S++import Prelude hiding (mod)++import Language.Futhark hiding (unscopeType)+import Language.Futhark.Semantic (includeToString)+import Language.Futhark.Traversals+import Language.Futhark.TypeChecker.Monad hiding (BoundV, checkQualNameWithEnv)+import Language.Futhark.TypeChecker.Types hiding (checkTypeDecl)+import Language.Futhark.TypeChecker.Unify hiding (Usage)+import qualified Language.Futhark.TypeChecker.Types as Types+import qualified Language.Futhark.TypeChecker.Monad as TypeM+import Futhark.Util.Pretty hiding (space, bool, group)++--- Uniqueness++data Usage = Consumed SrcLoc+           | Observed SrcLoc+           deriving (Eq, Ord, Show)++type Names = S.Set VName++-- | The consumption set is a Maybe so we can distinguish whether a+-- consumption took place, but the variable went out of scope since,+-- or no consumption at all took place.+data Occurence = Occurence { observed :: Names+                           , consumed :: Maybe Names+                           , location :: SrcLoc+                           }+             deriving (Eq, Show)++instance Located Occurence where+  locOf = locOf . location++observation :: Aliasing -> SrcLoc -> Occurence+observation = flip Occurence Nothing . S.map aliasVar++consumption :: Aliasing -> SrcLoc -> Occurence+consumption = Occurence S.empty . Just . S.map aliasVar++-- | A null occurence is one that we can remove without affecting+-- anything.+nullOccurence :: Occurence -> Bool+nullOccurence occ = S.null (observed occ) && isNothing (consumed occ)++-- | A seminull occurence is one that does not contain references to+-- any variables in scope.  The big difference is that a seminull+-- occurence may denote a consumption, as long as the array that was+-- consumed is now out of scope.+seminullOccurence :: Occurence -> Bool+seminullOccurence occ = S.null (observed occ) && maybe True S.null (consumed occ)++type Occurences = [Occurence]++type UsageMap = M.Map VName [Usage]++usageMap :: Occurences -> UsageMap+usageMap = foldl comb M.empty+  where comb m (Occurence obs cons loc) =+          let m' = S.foldl' (ins $ Observed loc) m obs+          in S.foldl' (ins $ Consumed loc) m' $ fromMaybe mempty cons+        ins v m k = M.insertWith (++) k [v] m++combineOccurences :: VName -> Usage -> Usage -> TermTypeM Usage+combineOccurences _ (Observed loc) (Observed _) = return $ Observed loc+combineOccurences name (Consumed wloc) (Observed rloc) =+  useAfterConsume (baseName name) rloc wloc+combineOccurences name (Observed rloc) (Consumed wloc) =+  useAfterConsume (baseName name) rloc wloc+combineOccurences name (Consumed loc1) (Consumed loc2) =+  consumeAfterConsume (baseName name) (max loc1 loc2) (min loc1 loc2)++checkOccurences :: Occurences -> TermTypeM ()+checkOccurences = void . M.traverseWithKey comb . usageMap+  where comb _    []     = return ()+        comb name (u:us) = foldM_ (combineOccurences name) u us++allObserved :: Occurences -> Names+allObserved = S.unions . map observed++allConsumed :: Occurences -> Names+allConsumed = S.unions . map (fromMaybe mempty . consumed)++allOccuring :: Occurences -> Names+allOccuring occs = allConsumed occs <> allObserved occs++anyConsumption :: Occurences -> Maybe Occurence+anyConsumption = find (isJust . consumed)++seqOccurences :: Occurences -> Occurences -> Occurences+seqOccurences occurs1 occurs2 =+  filter (not . nullOccurence) $ map filt occurs1 ++ occurs2+  where filt occ =+          occ { observed = observed occ `S.difference` postcons }+        postcons = allConsumed occurs2++altOccurences :: Occurences -> Occurences -> Occurences+altOccurences occurs1 occurs2 =+  filter (not . nullOccurence) $ map filt1 occurs1 ++ map filt2 occurs2+  where filt1 occ =+          occ { consumed = S.difference <$> consumed occ <*> pure cons2+              , observed = observed occ `S.difference` cons2 }+        filt2 occ =+          occ { consumed = consumed occ+              , observed = observed occ `S.difference` cons1 }+        cons1 = allConsumed occurs1+        cons2 = allConsumed occurs2++--- Scope management++data Checking+  = CheckingApply (Maybe (QualName VName)) Exp StructType StructType+  | CheckingReturn StructType StructType+  | CheckingAscription StructType StructType+  | CheckingLetGeneralise Name+  | CheckingParams (Maybe Name)+  | CheckingPattern UncheckedPattern InferredType+  | CheckingLoopBody StructType StructType+  | CheckingLoopInitial StructType StructType+  | CheckingRecordUpdate [Name] StructType StructType+  | CheckingRequired [StructType] StructType+  | CheckingBranches StructType StructType++instance Pretty Checking where+  ppr (CheckingApply f e expected actual) =+    header </>+    "Expected:" <+> align (ppr expected) </>+    "Actual:  " <+> align (ppr actual)+    where header =+            case f of+              Nothing ->+                "Cannot apply function to" <+>+                pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)."+              Just fname ->+                "Cannot apply" <+> pquote (ppr fname) <+> "to" <+>+                pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)."++  ppr (CheckingReturn expected actual) =+    "Function body does not have expected type." </>+    "Expected:" <+> align (ppr expected) </>+    "Actual:  " <+> align (ppr actual)++  ppr (CheckingAscription expected actual) =+    "Expression does not have expected type from explicit ascription." </>+    "Expected:" <+> align (ppr expected) </>+    "Actual:  " <+> align (ppr actual)++  ppr (CheckingLetGeneralise fname) =+    "Cannot generalise type of" <+> pquote (ppr fname) <> "."++  ppr (CheckingParams fname) =+    "Invalid use of parameters in" <+> pquote fname' <> "."+    where fname' = maybe "anonymous function" ppr fname++  ppr (CheckingPattern pat NoneInferred) =+    "Invalid pattern" <+> pquote (ppr pat) <> "."++  ppr (CheckingPattern pat (Ascribed t)) =+    "Pattern" <+> pquote (ppr pat) <+>+    "cannot match value of type" </>+    indent 2 (ppr t)++  ppr (CheckingLoopBody expected actual) =+    "Loop body does not have expected type." </>+    "Expected:" <+> align (ppr expected) </>+    "Actual:  " <+> align (ppr actual)++  ppr (CheckingLoopInitial expected actual) =+    "Initial loop values do not have expected type." </>+    "Expected:" <+> align (ppr expected) </>+    "Actual:  " <+> align (ppr actual)++  ppr (CheckingRecordUpdate fs expected actual) =+    "Type mismatch when updating record field" <+> pquote fs' <> "." </>+    "Existing:" <+> align (ppr expected) </>+    "New:     " <+> align (ppr actual)+    where fs' = mconcat $ punctuate "." $ map ppr fs++  ppr (CheckingRequired [expected] actual) =+    "Expression must must have type" <+> ppr expected <> "." </>+    "Actual type:" <+> align (ppr actual)++  ppr (CheckingRequired expected actual) =+    "Type of expression must must be one of " <+> expected' <> "." </>+    "Actual type:" <+> align (ppr actual)+    where expected' = commasep (map ppr expected)++  ppr (CheckingBranches t1 t2) =+    "Conditional branches differ in type." </>+    "Former:" <+> ppr t1 </>+    "Latter:" <+> ppr t2++-- | Whether something is a global or a local variable.+data Locality = Local | Global+              deriving (Show)++data ValBinding = BoundV Locality [TypeParam] PatternType+                -- ^ Aliases in parameters indicate the lexical+                -- closure.+                | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType)+                | EqualityF+                | WasConsumed SrcLoc+                deriving (Show)++-- | Type checking happens with access to this environment.  The+-- 'TermScope' will be extended during type-checking as bindings come into+-- scope.+data TermEnv = TermEnv { termScope :: TermScope+                       , termChecking :: Maybe Checking+                       , termLevel :: Level+                       }++data TermScope = TermScope { scopeVtable  :: M.Map VName ValBinding+                           , scopeTypeTable :: M.Map VName TypeBinding+                           , scopeModTable :: M.Map VName Mod+                           , scopeNameMap :: NameMap+                           } deriving (Show)++instance Semigroup TermScope where+  TermScope vt1 tt1 mt1 nt1 <> TermScope vt2 tt2 mt2 nt2 =+    TermScope (vt2 `M.union` vt1) (tt2 `M.union` tt1) (mt1 `M.union` mt2) (nt2 `M.union` nt1)++envToTermScope :: Env -> TermScope+envToTermScope env = TermScope { scopeVtable = vtable+                               , scopeTypeTable = envTypeTable env+                               , scopeNameMap = envNameMap env+                               , scopeModTable = envModTable env+                               }+  where vtable = M.mapWithKey valBinding $ envVtable env+        valBinding k (TypeM.BoundV tps v) =+          BoundV Global tps $ v `setAliases`+          (if arrayRank v > 0 then S.singleton (AliasBound k) else mempty)++withEnv :: TermEnv -> Env -> TermEnv+withEnv tenv env = tenv { termScope = termScope tenv <> envToTermScope env }++overloadedTypeVars :: Constraints -> Names+overloadedTypeVars = mconcat . map f . M.elems+  where f (_, HasFields fs _) = mconcat $ map typeVars $ M.elems fs+        f _ = mempty++-- | Get the type of an expression, with top level type variables+-- substituted.  Never call 'typeOf' directly (except in a few+-- carefully inspected locations)!+expType :: Exp -> TermTypeM PatternType+expType = normPatternType . typeOf++-- | Get the type of an expression, with all type variables+-- substituted.  Slower than 'expType', but sometimes necessary.+-- Never call 'typeOf' directly (except in a few carefully inspected+-- locations)!+expTypeFully :: Exp -> TermTypeM PatternType+expTypeFully = normTypeFully . typeOf++-- Wrap a function name to give it a vacuous Eq instance for SizeSource.+newtype FName = FName (Maybe (QualName VName))+              deriving (Show)++instance Eq FName where+  _ == _ = True++instance Ord FName where+  compare _ _ = EQ++-- | What was the source of some existential size?  This is used for+-- using the same existential variable if the same source is+-- encountered in multiple locations.+data SizeSource = SourceArg FName (ExpBase NoInfo VName)+                | SourceBound (ExpBase NoInfo VName)+                | SourceSlice+                  (Maybe (DimDecl VName))+                  (Maybe (ExpBase NoInfo VName))+                  (Maybe (ExpBase NoInfo VName))+                  (Maybe (ExpBase NoInfo VName))+                deriving (Eq, Ord, Show)++-- | The state is a set of constraints and a counter for generating+-- type names.  This is distinct from the usual counter we use for+-- generating unique names, as these will be user-visible.+data TermTypeState = TermTypeState+                     { stateConstraints :: Constraints+                     , stateCounter :: !Int+                     , stateDimTable :: M.Map SizeSource VName+                       -- ^ Mapping function arguments encountered to+                       -- the sizes they ended up generating (when+                       -- they could not be substituted directly).+                       -- This happens for function arguments that are+                       -- not constants or names.+                     }++newtype TermTypeM a = TermTypeM (RWST+                                 TermEnv+                                 Occurences+                                 TermTypeState+                                 TypeM+                                 a)+  deriving (Monad, Functor, Applicative,+            MonadReader TermEnv,+            MonadWriter Occurences,+            MonadState TermTypeState,+            MonadError TypeError)++instance MonadUnify TermTypeM where+  getConstraints = gets stateConstraints+  putConstraints x = modify $ \s -> s { stateConstraints = x }++  newTypeVar loc desc = do+    i <- incCounter+    v <- newID $ mkTypeVarName desc i+    constrain v $ NoConstraint Lifted $ mkUsage' loc+    return $ Scalar $ TypeVar mempty Nonunique (typeName v) []++  curLevel = asks termLevel++  newDimVar loc rigidity name = do+    i <- incCounter+    dim <- newID $ mkTypeVarName name i+    case rigidity of+      Rigid rsrc -> constrain dim $ UnknowableSize loc rsrc+      Nonrigid -> constrain dim $ Size Nothing $ mkUsage' loc+    return dim++  unifyError loc notes bcs doc = do+    checking <- asks termChecking+    case checking of+      Just checking' ->+        throwError $ TypeError (srclocOf loc) notes $+        ppr checking' <> line </> doc <> ppr bcs+      Nothing ->+        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs++  matchError loc notes bcs t1 t2 = do+    checking <- asks termChecking+    case checking of+      Just checking'+        | hasNoBreadCrumbs bcs ->+            throwError $ TypeError (srclocOf loc) notes $+            ppr checking'+        | otherwise ->+            throwError $ TypeError (srclocOf loc) notes $+            ppr checking' <> line </> doc <> ppr bcs+      Nothing ->+        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+    where doc = "Types" </>+                indent 2 (ppr t1) </>+                "and" </>+                indent 2 (ppr t2) </>+                "do not match."++onFailure :: Checking -> TermTypeM a -> TermTypeM a+onFailure c = local $ \env -> env { termChecking = Just c }++runTermTypeM :: TermTypeM a -> TypeM (a, Occurences)+runTermTypeM (TermTypeM m) = do+  initial_scope <- (initialTermScope <>) . envToTermScope <$> askEnv+  let initial_tenv = TermEnv { termScope = initial_scope+                             , termChecking = Nothing+                             , termLevel = 0+                             }+  evalRWST m initial_tenv $ TermTypeState mempty 0 mempty++liftTypeM :: TypeM a -> TermTypeM a+liftTypeM = TermTypeM . lift++localScope :: (TermScope -> TermScope) -> TermTypeM a -> TermTypeM a+localScope f = local $ \tenv -> tenv { termScope = f $ termScope tenv }++incCounter :: TermTypeM Int+incCounter = do s <- get+                put s { stateCounter = stateCounter s + 1 }+                return $ stateCounter s++extSize :: SrcLoc -> SizeSource -> TermTypeM (DimDecl VName, Maybe VName)+extSize loc e = do+  prev <- gets $ M.lookup e . stateDimTable+  case prev of+    Nothing -> do+      let rsrc = case e of+                   SourceArg (FName fname) e' ->+                     RigidArg fname $ prettyOneLine e'+                   SourceBound e' ->+                     RigidBound $ prettyOneLine e'+                   SourceSlice d i j s  ->+                     RigidSlice d $ prettyOneLine $ DimSlice i j s+      d <- newDimVar loc (Rigid rsrc) "argdim"+      modify $ \s -> s { stateDimTable = M.insert e d $ stateDimTable s }+      return (NamedDim $ qualName d,+              Just d)+    Just d -> return (NamedDim $ qualName d,+                      Nothing)++-- Any argument sizes created with 'extSize' inside the given action+-- will be removed once the action finishes.  This is to ensure that+-- just because e.g. @n+1@ appears as a size in one branch of a+-- conditional, that doesn't mean it's also available in the other branch.+noSizeEscape :: TermTypeM a -> TermTypeM a+noSizeEscape m = do+  dimtable <- gets stateDimTable+  x <- m+  modify $ \s -> s { stateDimTable = dimtable }+  return x++constrain :: VName -> Constraint -> TermTypeM ()+constrain v c = do+  lvl <- curLevel+  modifyConstraints $ M.insert v (lvl, c)++incLevel :: TermTypeM a -> TermTypeM a+incLevel = local $ \env -> env { termLevel = termLevel env + 1 }++initialTermScope :: TermScope+initialTermScope = TermScope { scopeVtable = initialVtable+                             , scopeTypeTable = mempty+                             , scopeNameMap = topLevelNameMap+                             , scopeModTable = mempty+                             }+  where initialVtable = M.fromList $ mapMaybe addIntrinsicF $ M.toList intrinsics++        prim = Scalar . Prim+        arrow x y = Scalar $ Arrow mempty Unnamed x y++        addIntrinsicF (name, IntrinsicMonoFun pts t) =+          Just (name, BoundV Global [] $ arrow pts' $ prim t)+          where pts' = case pts of [pt] -> prim pt+                                   _    -> tupleRecord $ map prim pts++        addIntrinsicF (name, IntrinsicOverloadedFun ts pts rts) =+          Just (name, OverloadedF ts pts rts)+        addIntrinsicF (name, IntrinsicPolyFun tvs pts rt) =+          Just (name, BoundV Global tvs $+                      fromStruct $ Scalar $ Arrow mempty Unnamed pts' rt)+          where pts' = case pts of [pt] -> pt+                                   _    -> tupleRecord pts+        addIntrinsicF (name, IntrinsicEquality) =+          Just (name, EqualityF)+        addIntrinsicF _ = Nothing++instance MonadTypeChecker TermTypeM where+  warn loc problem = liftTypeM $ warn loc problem+  newName = liftTypeM . newName+  newID = liftTypeM . newID++  checkQualName space name loc = snd <$> checkQualNameWithEnv space name loc++  bindNameMap m = localScope $ \scope ->+    scope { scopeNameMap = m <> scopeNameMap scope }++  bindVal v (TypeM.BoundV tps t) = localScope $ \scope ->+    scope { scopeVtable = M.insert v vb $ scopeVtable scope }+    where vb = BoundV Local tps $ fromStruct t++  lookupType loc qn = do+    outer_env <- liftTypeM askEnv+    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc+    case M.lookup name $ scopeTypeTable scope of+      Nothing -> undefinedType loc qn+      Just (TypeAbbr l ps def) ->+        return (qn', ps, qualifyTypeVars outer_env (map typeParamName ps) qs def, l)++  lookupMod loc qn = do+    (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc+    case M.lookup name $ scopeModTable scope of+      Nothing -> unknownVariableError Term qn loc+      Just m  -> return (qn', m)++  lookupVar loc qn = do+    outer_env <- liftTypeM askEnv+    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc+    let usage = mkUsage loc $ "use of " ++ quote (pretty qn)++    t <- case M.lookup name $ scopeVtable scope of+      Nothing -> typeError loc mempty $+                 "Unknown variable" <+> pquote (ppr qn) <> "."++      Just (WasConsumed wloc) -> useAfterConsume (baseName name) loc wloc++      Just (BoundV _ tparams t)+        | "_" `isPrefixOf` baseString name -> underscoreUse loc qn+        | otherwise -> do+            (tnames, t') <- instantiateTypeScheme loc tparams t+            return $ qualifyTypeVars outer_env tnames qs t'++      Just EqualityF -> do+        argtype <- newTypeVar loc "t"+        equalityType usage argtype+        return $+          Scalar $ Arrow mempty Unnamed argtype $+          Scalar $ Arrow mempty Unnamed argtype $ Scalar $ Prim Bool++      Just (OverloadedF ts pts rt) -> do+        argtype <- newTypeVar loc "t"+        mustBeOneOf ts usage argtype+        let (pts', rt') = instOverloaded argtype pts rt+            arrow xt yt = Scalar $ Arrow mempty Unnamed xt yt+        return $ fromStruct $ foldr arrow rt' pts'++    observe $ Ident name (Info t) loc+    return (qn', t)++      where instOverloaded argtype pts rt =+              (map (maybe (toStruct argtype) (Scalar . Prim)) pts,+               maybe (toStruct argtype) (Scalar . Prim) rt)++  checkNamedDim loc v = do+    (v', t) <- lookupVar loc v+    onFailure (CheckingRequired [Scalar $ Prim $ Signed Int32] (toStruct t)) $+      unify (mkUsage loc "use as array size") (toStruct t) $+      Scalar $ Prim $ Signed Int32+    return v'++  typeError loc notes s = do+    checking <- asks termChecking+    case checking of+      Just checking' ->+        throwError $ TypeError (srclocOf loc) notes (ppr checking' <> line </> s)+      Nothing ->+        throwError $ TypeError (srclocOf loc) notes s++checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)+checkQualNameWithEnv space qn@(QualName quals name) loc = do+  scope <- asks termScope+  descend scope quals+  where descend scope []+          | Just name' <- M.lookup (space, name) $ scopeNameMap scope =+              return (scope, name')+          | otherwise =+              unknownVariableError space qn loc++        descend scope (q:qs)+          | Just (QualName _ q') <- M.lookup (Term, q) $ scopeNameMap scope,+            Just res <- M.lookup q' $ scopeModTable scope =+              case res of+                -- Check if we are referring to the magical intrinsics+                -- module.+                _ | baseTag q' <= maxIntrinsicTag ->+                      checkIntrinsic space qn loc+                ModEnv q_scope -> do+                  (scope', QualName qs' name') <- descend (envToTermScope q_scope) qs+                  return (scope', QualName (q':qs') name')+                ModFun{} -> unappliedFunctor loc+          | otherwise =+              unknownVariableError space qn loc++checkIntrinsic :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)+checkIntrinsic space qn@(QualName _ name) loc+  | Just v <- M.lookup (space, name) intrinsicsNameMap = do+      me <- liftTypeM askImportName+      unless ("/prelude" `isPrefixOf` includeToString me) $+        warn loc "Using intrinsic functions directly can easily crash the compiler or result in wrong code generation."+      scope <- asks termScope+      return (scope, v)+  | otherwise =+      unknownVariableError space qn loc++-- | Wrap 'Types.checkTypeDecl' to also perform an observation of+-- every size in the type.+checkTypeDecl :: TypeDeclBase NoInfo Name -> TermTypeM (TypeDeclBase Info VName)+checkTypeDecl tdecl = do+  (tdecl', _) <- Types.checkTypeDecl tdecl+  mapM_ observeDim $ nestedDims $ unInfo $ expandedType tdecl'+  return tdecl'+  where observeDim (NamedDim v) =+          observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int32) noLoc+        observeDim _ = return ()++-- | Instantiate a type scheme with fresh type variables for its type+-- parameters. Returns the names of the fresh type variables, the+-- instance list, and the instantiated type.+instantiateTypeScheme :: SrcLoc -> [TypeParam] -> PatternType+                      -> TermTypeM ([VName], PatternType)+instantiateTypeScheme loc tparams t = do+  let tnames = map typeParamName tparams+  (tparam_names, tparam_substs) <- unzip <$> mapM (instantiateTypeParam loc) tparams+  let substs = M.fromList $ zip tnames tparam_substs+      t' = applySubst (`M.lookup` substs) t+  return (tparam_names, t')++-- | Create a new type name and insert it (unconstrained) in the+-- substitution map.+instantiateTypeParam :: Monoid as => SrcLoc -> TypeParam -> TermTypeM (VName, Subst (TypeBase dim as))+instantiateTypeParam loc tparam = do+  i <- incCounter+  v <- newID $ mkTypeVarName (takeWhile isAscii (baseString (typeParamName tparam))) i+  case tparam of TypeParamType x _ _ -> do+                   constrain v $ NoConstraint x $ mkUsage' loc+                   return (v, Subst $ Scalar $ TypeVar mempty Nonunique (typeName v) [])+                 TypeParamDim{} -> do+                   constrain v $ Size Nothing $ mkUsage' loc+                   return (v, SizeSubst $ NamedDim $ qualName v)++newArrayType :: SrcLoc -> String -> Int -> TermTypeM (StructType, StructType)+newArrayType loc desc r = do+  v <- newID $ nameFromString desc+  constrain v $ NoConstraint Unlifted $ mkUsage' loc+  dims <- replicateM r $ newDimVar loc Nonrigid "dim"+  let rowt = TypeVar () Nonunique (typeName v) []+  return (Array () Nonunique rowt (ShapeDecl $ map (NamedDim . qualName) dims),+          Scalar rowt)++--- Errors++useAfterConsume :: Name -> SrcLoc -> SrcLoc -> TermTypeM a+useAfterConsume name rloc wloc =+  typeError rloc mempty $+  "Variable" <+> pquote (pprName name) <+> "previously consumed at" <+>+  text (locStrRel rloc wloc) <> ".  (Possibly through aliasing.)"++consumeAfterConsume :: Name -> SrcLoc -> SrcLoc -> TermTypeM a+consumeAfterConsume name loc1 loc2 =+  typeError loc2 mempty $+  "Variable" <+> pprName name <+> "previously consumed at" <+>+  text (locStrRel loc2 loc1) <> "."++badLetWithValue :: SrcLoc -> TermTypeM a+badLetWithValue loc =+  typeError loc mempty+  "New value for elements in let-with shares data with source array.  This is illegal, as it prevents in-place modification."++returnAliased :: Name -> Name -> SrcLoc -> TermTypeM ()+returnAliased fname name loc =+  typeError loc mempty $+  "Unique return value of" <+> pquote (pprName fname) <+>+  "is aliased to" <+> pquote (pprName name) <+> ", which is not consumed."++uniqueReturnAliased :: Name -> SrcLoc -> TermTypeM a+uniqueReturnAliased fname loc =+  typeError loc mempty $+  "A unique tuple element of return value of" <+>+  pquote (pprName fname) <+> "is aliased to some other tuple component."++--- Basic checking++-- | Determine if the two types of identical, ignoring uniqueness.+-- Mismatched dimensions are turned into fresh rigid type variables.+-- Causes a 'TypeError' if they fail to match, and otherwise returns+-- one of them.+unifyBranchTypes :: SrcLoc -> PatternType -> PatternType -> TermTypeM (PatternType, [VName])+unifyBranchTypes loc t1 t2 =+  onFailure (CheckingBranches (toStruct t1) (toStruct t2)) $+  unifyMostCommon (mkUsage loc "unification of branch results") t1 t2++unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatternType, [VName])+unifyBranches loc e1 e2 = do+  e1_t <- expTypeFully e1+  e2_t <- expTypeFully e2+  unifyBranchTypes loc e1_t e2_t++--- General binding.++doNotShadow :: [String]+doNotShadow = ["&&", "||"]++data InferredType = NoneInferred+                  | Ascribed PatternType+++checkPattern' :: UncheckedPattern -> InferredType+              -> TermTypeM Pattern++checkPattern' (PatternParens p loc) t =+  PatternParens <$> checkPattern' p t <*> pure loc++checkPattern' (Id name _ loc) _+  | name' `elem` doNotShadow =+      typeError loc mempty $ "The" <+> text name' <+> "operator may not be redefined."+  where name' = nameToString name++checkPattern' (Id name NoInfo loc) (Ascribed t) = do+  name' <- newID name+  return $ Id name' (Info t) loc+checkPattern' (Id name NoInfo loc) NoneInferred = do+  name' <- newID name+  t <- newTypeVar loc "t"+  return $ Id name' (Info t) loc++checkPattern' (Wildcard _ loc) (Ascribed t) =+  return $ Wildcard (Info $ t `setUniqueness` Nonunique) loc+checkPattern' (Wildcard NoInfo loc) NoneInferred = do+  t <- newTypeVar loc "t"+  return $ Wildcard (Info t) loc++checkPattern' (TuplePattern ps loc) (Ascribed t)+  | Just ts <- isTupleRecord t, length ts == length ps =+      TuplePattern <$> zipWithM checkPattern' ps (map Ascribed ts) <*> pure loc+checkPattern' p@(TuplePattern ps loc) (Ascribed t) = do+  ps_t <- replicateM (length ps) (newTypeVar loc "t")+  unify (mkUsage loc "matching a tuple pattern") (tupleRecord ps_t) $ toStruct t+  t' <- normTypeFully t+  checkPattern' p $ Ascribed t'+checkPattern' (TuplePattern ps loc) NoneInferred =+  TuplePattern <$> mapM (`checkPattern'` NoneInferred) ps <*> pure loc++checkPattern' (RecordPattern p_fs _) _+  | Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs =+      typeError fp mempty $+      "Underscore-prefixed fields are not allowed." </>+      "Did you mean" <> dquotes (text (drop 1 (nameToString f)) <> "=_") <> "?"++checkPattern' (RecordPattern p_fs loc) (Ascribed (Scalar (Record t_fs)))+  | sort (map fst p_fs) == sort (M.keys t_fs) =+    RecordPattern . M.toList <$> check <*> pure loc+    where check = traverse (uncurry checkPattern') $ M.intersectionWith (,)+                  (M.fromList p_fs) (fmap Ascribed t_fs)+checkPattern' p@(RecordPattern fields loc) (Ascribed t) = do+  fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields++  when (sort (M.keys fields') /= sort (map fst fields)) $+    typeError loc mempty $ "Duplicate fields in record pattern" <+> ppr p <> "."++  unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStruct t+  t' <- normTypeFully t+  checkPattern' p $ Ascribed t'+checkPattern' (RecordPattern fs loc) NoneInferred =+  RecordPattern . M.toList <$> traverse (`checkPattern'` NoneInferred) (M.fromList fs) <*> pure loc++checkPattern' (PatternAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do+  (t', st_nodims, _) <- checkTypeExp t+  (st, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid st_nodims++  let st' = fromStruct st+  case maybe_outer_t of+    Ascribed outer_t -> do+      unify (mkUsage loc "explicit type ascription") (toStruct st) (toStruct outer_t)++      -- We also have to make sure that uniqueness matches.  This is+      -- done explicitly, because it is ignored by unification.+      st'' <- normTypeFully st'+      outer_t' <- normTypeFully outer_t+      case unifyTypesU unifyUniqueness st'' outer_t' of+        Just outer_t'' ->+          PatternAscription <$> checkPattern' p (Ascribed outer_t'') <*>+          pure (TypeDecl t' (Info st)) <*> pure loc+        Nothing ->+          typeError loc mempty $+          "Cannot match type" <+> pquote (ppr outer_t') <+> "with expected type" <+>+          pquote (ppr st'') <> "."++    NoneInferred ->+      PatternAscription <$> checkPattern' p (Ascribed st') <*>+      pure (TypeDecl t' (Info st)) <*> pure loc+ where unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing++checkPattern' (PatternLit e NoInfo loc) (Ascribed t) = do+  e' <- checkExp e+  t' <- expTypeFully e'+  unify (mkUsage loc "matching against literal") (toStruct t') (toStruct t)+  return $ PatternLit e' (Info t') loc++checkPattern' (PatternLit e NoInfo loc) NoneInferred = do+  e' <- checkExp e+  t' <- expTypeFully e'+  return $ PatternLit e' (Info t') loc++checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))+  | Just ts <- M.lookup n cs = do+      ps' <- zipWithM checkPattern' ps $ map Ascribed ts+      return $ PatternConstr n (Info (Scalar (Sum cs))) ps' loc++checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed t) = do+  t' <- newTypeVar loc "t"+  ps' <- mapM (`checkPattern'` NoneInferred) ps+  mustHaveConstr usage n t' (patternStructType <$> ps')+  unify usage t' (toStruct t)+  t'' <- normTypeFully t+  return $ PatternConstr n (Info t'') ps' loc+  where usage = mkUsage loc "matching against constructor"++checkPattern' (PatternConstr n NoInfo ps loc) NoneInferred = do+  ps' <- mapM (`checkPattern'` NoneInferred) ps+  t <- newTypeVar loc "t"+  mustHaveConstr usage n t (patternStructType <$> ps')+  return $ PatternConstr n (Info $ fromStruct t) ps' loc+  where usage = mkUsage loc "matching against constructor"++patternNameMap :: Pattern -> NameMap+patternNameMap = M.fromList . map asTerm . S.toList . patternNames+  where asTerm v = ((Term, baseName v), qualName v)++checkPattern :: UncheckedPattern -> InferredType -> (Pattern -> TermTypeM a)+             -> TermTypeM a+checkPattern p t m = do+  checkForDuplicateNames [p]+  p' <- onFailure (CheckingPattern p t) $ checkPattern' p t+  bindNameMap (patternNameMap p') $ m p'++binding :: [Ident] -> TermTypeM a -> TermTypeM a+binding bnds = check . handleVars+  where handleVars m =+          localScope (`bindVars` bnds) $ do++          -- Those identifiers that can potentially also be sizes are+          -- added as type constraints.  This is necessary so that we+          -- can properly detect scope violations during unification.+          -- We do this for *all* identifiers, not just those that are+          -- integers, because they may become integers later due to+          -- inference...+          forM_ bnds $ \ident ->+            constrain (identName ident) $ ParamSize $ srclocOf ident+          m++        bindVars :: TermScope -> [Ident] -> TermScope+        bindVars = foldl bindVar++        bindVar :: TermScope -> Ident -> TermScope+        bindVar scope (Ident name (Info tp) _) =+          let inedges = boundAliases $ aliases tp+              update (BoundV l tparams in_t)+                -- If 'name' is record or sum-typed, don't alias the+                -- components to 'name', because these no identity+                -- beyond their components.+                | Array{} <- tp = BoundV l tparams (in_t `addAliases` S.insert (AliasBound name))+                | otherwise = BoundV l tparams in_t+              update b = b++              tp' = tp `addAliases` S.insert (AliasBound name)+          in scope { scopeVtable = M.insert name (BoundV Local [] tp') $+                                   adjustSeveral update inedges $+                                   scopeVtable scope+                   }++        adjustSeveral f = flip $ foldl $ flip $ M.adjust f++        -- Check whether the bound variables have been used correctly+        -- within their scope.+        check m = do+          (a, usages) <- collectBindingsOccurences m+          checkOccurences usages++          mapM_ (checkIfUsed usages) bnds++          return a++        -- Collect and remove all occurences in @bnds@.  This relies+        -- on the fact that no variables shadow any other.+        collectBindingsOccurences m = pass $ do+          (x, usage) <- listen m+          let (relevant, rest) = split usage+          return ((x, relevant), const rest)+          where split = unzip .+                        map (\occ ->+                             let (obs1, obs2) = divide $ observed occ+                                 occ_cons = divide <$> consumed occ+                                 con1 = fst <$> occ_cons+                                 con2 = snd <$> occ_cons+                             in (occ { observed = obs1, consumed = con1 },+                                 occ { observed = obs2, consumed = con2 }))+                names = S.fromList $ map identName bnds+                divide s = (s `S.intersection` names, s `S.difference` names)++bindingTypes :: [Either (VName, TypeBinding) (VName, Constraint)]+             -> TermTypeM a -> TermTypeM a+bindingTypes types m = do+  lvl <- curLevel+  modifyConstraints (<>M.map (lvl,) (M.fromList constraints))+  localScope extend m+  where (tbinds, constraints) = partitionEithers types+        extend scope = scope {+          scopeTypeTable = M.fromList tbinds <> scopeTypeTable scope+          }++bindingTypeParams :: [TypeParam] -> TermTypeM a -> TermTypeM a+bindingTypeParams tparams = binding (mapMaybe typeParamIdent tparams) .+                            bindingTypes (concatMap typeParamType tparams)+  where typeParamType (TypeParamType l v loc) =+          [ Left (v, TypeAbbr l [] (Scalar (TypeVar () Nonunique (typeName v) [])))+          , Right (v, ParamType l loc) ]+        typeParamType (TypeParamDim v loc) =+          [ Right (v, ParamSize loc) ]++typeParamIdent :: TypeParam -> Maybe Ident+typeParamIdent (TypeParamDim v loc) =+  Just $ Ident v (Info $ Scalar $ Prim $ Signed Int32) loc+typeParamIdent _ = Nothing++bindingIdent :: IdentBase NoInfo Name -> PatternType -> (Ident -> TermTypeM a)+             -> TermTypeM a+bindingIdent (Ident v NoInfo vloc) t m =+  bindSpaced [(Term, v)] $ do+    v' <- checkName Term v vloc+    let ident = Ident v' (Info t) vloc+    binding [ident] $ m ident++bindingParams :: [UncheckedTypeParam]+              -> [UncheckedPattern]+              -> ([TypeParam] -> [Pattern] -> TermTypeM a) -> TermTypeM a+bindingParams tps orig_ps m = do+  checkForDuplicateNames orig_ps+  checkTypeParams tps $ \tps' -> bindingTypeParams tps' $ do+    let descend ps' (p:ps) =+          checkPattern p NoneInferred $ \p' ->+            binding (S.toList $ patternIdents p') $ descend (p':ps') ps+        descend ps' [] = do+          -- Perform an observation of every type parameter.  This+          -- prevents unused-name warnings for otherwise unused+          -- dimensions.+          mapM_ observe $ mapMaybe typeParamIdent tps'+          m tps' $ reverse ps'++    descend [] orig_ps++bindingPattern :: PatternBase NoInfo Name -> InferredType+               -> (Pattern -> TermTypeM a) -> TermTypeM a+bindingPattern p t m = do+  checkForDuplicateNames [p]+  checkPattern p t $ \p' -> binding (S.toList $ patternIdents p') $ do+    -- Perform an observation of every declared dimension.  This+    -- prevents unused-name warnings for otherwise unused dimensions.+    mapM_ observe $ patternDims p'++    m p'++patternDims :: Pattern -> [Ident]+patternDims (PatternParens p _) = patternDims p+patternDims (TuplePattern pats _) = concatMap patternDims pats+patternDims (PatternAscription p (TypeDecl _ (Info t)) _) =+  patternDims p <> mapMaybe (dimIdent (srclocOf p)) (nestedDims t)+  where dimIdent _ AnyDim            = Nothing+        dimIdent _ (ConstDim _)      = Nothing+        dimIdent _ NamedDim{}        = Nothing+patternDims _ = []++sliceShape :: Maybe (SrcLoc, Rigidity) -> [DimIndex] -> TypeBase (DimDecl VName) as+           -> TermTypeM (TypeBase (DimDecl VName) as, [VName])+sliceShape r slice t@(Array als u et (ShapeDecl orig_dims)) =+  runWriterT $ setDims <$> adjustDims slice orig_dims+  where setDims []    = stripArray (length orig_dims) t+        setDims dims' = Array als u et $ ShapeDecl dims'++        -- If the result is supposed to be AnyDim or a nonrigid size+        -- variable, then don't bother trying to create+        -- non-existential sizes.  This is necessary to make programs+        -- type-check without too much ceremony; see+        -- e.g. tests/inplace5.fut.+        isRigid Rigid{} = True+        isRigid _ = False+        refine_sizes = maybe False (isRigid . snd) r++        sliceSize orig_d i j stride =+          case r of+            Just (loc, Rigid _) -> do+              (d, ext) <-+                lift $ extSize loc $+                SourceSlice orig_d' (bareExp <$> i) (bareExp <$> j) (bareExp <$> stride)+              tell $ maybeToList ext+              return d+            Just (loc, Nonrigid) ->+              lift $ NamedDim . qualName <$> newDimVar loc Nonrigid "slice_dim"+            Nothing ->+              pure AnyDim+          where+            -- The original size does not matter if the slice is fully specified.+            orig_d' | isJust i, isJust j = Nothing+                    | otherwise = Just orig_d++        adjustDims (DimFix{} : idxes') (_:dims) =+          adjustDims idxes' dims++        -- Pattern match some known slices to be non-existential.+        adjustDims (DimSlice i j stride : idxes') (_:dims)+          | refine_sizes,+            maybe True ((==Just 0) . isInt32) i,+            Just j' <- maybeDimFromExp =<< j,+            maybe True ((==Just 1) . isInt32) stride =+              (j':) <$> adjustDims idxes' dims++        adjustDims (DimSlice Nothing Nothing stride : idxes') (d:dims)+          | refine_sizes,+            maybe True (maybe False ((==1) . abs) . isInt32) stride =+              (d:) <$> adjustDims idxes' dims++        adjustDims (DimSlice i j stride : idxes') (d:dims) =+          (:) <$> sliceSize d i j stride <*> adjustDims idxes' dims++        adjustDims _ dims =+          pure dims++sliceShape _ _ t = pure (t, [])++--- Main checkers++-- | @require ts e@ causes a 'TypeError' if @expType e@ is not one of+-- the types in @ts@.  Otherwise, simply returns @e@.+require :: String -> [PrimType] -> Exp -> TermTypeM Exp+require why ts e = do mustBeOneOf ts (mkUsage (srclocOf e) why) . toStruct =<< expType e+                      return e++unifies :: String -> StructType -> Exp -> TermTypeM Exp+unifies why t e = do+  unify (mkUsage (srclocOf e) why) t =<< toStruct <$> expType e+  return e++-- The closure of a lambda or local function are those variables that+-- it references, and which local to the current top-level function.+lexicalClosure :: [Pattern] -> Occurences -> TermTypeM Aliasing+lexicalClosure params closure = do+  vtable <- asks $ scopeVtable . termScope+  let isLocal v = case v `M.lookup` vtable of+                    Just (BoundV Local _ _) -> True+                    _ -> False+  return $ S.map AliasBound $ S.filter isLocal $+    allOccuring closure S.\\ mconcat (map patternNames params)++noAliasesIfOverloaded :: PatternType -> TermTypeM PatternType+noAliasesIfOverloaded t@(Scalar (TypeVar _ u tn [])) = do+  subst <- fmap snd . M.lookup (typeLeaf tn) <$> getConstraints+  case subst of+    Just Overloaded{} -> return $ Scalar $ TypeVar mempty u tn []+    _ -> return t+noAliasesIfOverloaded t =+  return t++-- Check the common parts of ascription and coercion.+checkAscript :: SrcLoc+             -> UncheckedTypeDecl+             -> UncheckedExp+             -> (StructType -> StructType)+             -> TermTypeM (TypeDecl, Exp)+checkAscript loc decl e shapef = do+  decl' <- checkTypeDecl decl+  e' <- checkExp e+  t <- expTypeFully e'++  (decl_t_nonrigid, _) <-+    instantiateEmptyArrayDims loc "impl" Nonrigid $ shapef $+    unInfo $ expandedType decl'++  onFailure (CheckingAscription (unInfo $ expandedType decl') (toStruct t)) $+    unify (mkUsage loc "type ascription") decl_t_nonrigid (toStruct t)++  -- We also have to make sure that uniqueness matches.  This is done+  -- explicitly, because uniqueness is ignored by unification.+  t' <- normTypeFully t+  decl_t' <- normTypeFully $ unInfo $ expandedType decl'+  unless (t' `subtypeOf` anySizes decl_t') $+    typeError loc mempty $ "Type" <+> pquote (ppr t') <+> "is not a subtype of" <+>+    pquote (ppr decl_t') <> "."++  return (decl', e')++unscopeType :: SrcLoc+            -> M.Map VName Ident+            -> PatternType+            -> TermTypeM (PatternType, [VName])+unscopeType tloc unscoped t = do+  (t', m) <- runStateT (traverseDims onDim t) mempty+  return (t' `addAliases` S.map unAlias, M.elems m)+  where onDim p (NamedDim d)+          | Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped =+              if p == PosImmediate || p == PosParam+              then inst loc $ qualLeaf d+              else return AnyDim+        onDim _ d = return d++        inst loc d = do+          prev <- gets $ M.lookup d+          case prev of+            Just d' -> return $ NamedDim $ qualName d'+            Nothing -> do+              d' <- lift $ newDimVar tloc (Rigid $ RigidOutOfScope loc d) "d"+              modify $ M.insert d d'+              return $ NamedDim $ qualName d'++        unAlias (AliasBound v) | v `M.member` unscoped = AliasFree v+        unAlias a = a++-- 'checkApplyExp' is like 'checkExp', but tries to find the "root+-- function", for better error messages.+checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)++checkApplyExp (Apply e1 e2 _ _ loc) = do+  (e1', (fname, i)) <- checkApplyExp e1+  arg <- checkArg e2+  t <- expType e1'+  (t1, rt, argext, exts) <- checkApply loc (fname, i) t arg+  return (Apply e1' (argExp arg) (Info (diet t1, argext)) (Info rt, Info exts) loc,+          (fname, i+1))++checkApplyExp e = do+  e' <- checkExp e+  return (e',+          (case e' of Var qn _ _ -> Just qn+                      _ -> Nothing,+           0))++checkExp :: UncheckedExp -> TermTypeM Exp++checkExp (Literal val loc) =+  return $ Literal val loc++checkExp (StringLit vs loc) =+  return $ StringLit vs loc++checkExp (IntLit val NoInfo loc) = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t+  return $ IntLit val (Info $ fromStruct t) loc++checkExp (FloatLit val NoInfo loc) = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyFloatType (mkUsage loc "float literal") t+  return $ FloatLit val (Info $ fromStruct t) loc++checkExp (TupLit es loc) =+  TupLit <$> mapM checkExp es <*> pure loc++checkExp (RecordLit fs loc) = do+  fs' <- evalStateT (mapM checkField fs) mempty++  return $ RecordLit fs' loc+  where checkField (RecordFieldExplicit f e rloc) = do+          errIfAlreadySet f rloc+          modify $ M.insert f rloc+          RecordFieldExplicit f <$> lift (checkExp e) <*> pure rloc+        checkField (RecordFieldImplicit name NoInfo rloc) = do+          errIfAlreadySet name rloc+          (QualName _ name', t) <- lift $ lookupVar rloc $ qualName name+          modify $ M.insert name rloc+          return $ RecordFieldImplicit name' (Info t) rloc++        errIfAlreadySet f rloc = do+          maybe_sloc <- gets $ M.lookup f+          case maybe_sloc of+            Just sloc ->+              lift $ typeError rloc mempty $ "Field" <+> pquote (ppr f) <+>+              "previously defined at" <+> text (locStrRel rloc sloc) <> "."+            Nothing -> return ()++checkExp (ArrayLit all_es _ loc) =+  -- Construct the result type and unify all elements with it.  We+  -- only create a type variable for empty arrays; otherwise we use+  -- the type of the first element.  This significantly cuts down on+  -- the number of type variables generated for pathologically large+  -- multidimensional array literals.+  case all_es of+    [] -> do et <- newTypeVar loc "t"+             t <- arrayOfM loc et (ShapeDecl [ConstDim 0]) Unique+             return $ ArrayLit [] (Info t) loc+    e:es -> do+      e' <- checkExp e+      et <- expType e'+      es' <- mapM (unifies "type of first array element" (toStruct et) <=< checkExp) es+      et' <- normTypeFully et+      t <- arrayOfM loc et' (ShapeDecl [ConstDim $ length all_es]) Unique+      return $ ArrayLit (e':es') (Info t) loc++checkExp (Range start maybe_step end _ loc) = do+  start' <- require "use in range expression" anyIntType =<< checkExp start+  start_t <- toStruct <$> expTypeFully start'+  maybe_step' <- case maybe_step of+    Nothing -> return Nothing+    Just step -> do+      let warning = warn loc "First and second element of range are identical, this will produce an empty array."+      case (start, step) of+        (Literal x _, Literal y _) -> when (x == y) warning+        (Var x_name _ _, Var y_name _ _) -> when (x_name == y_name) warning+        _ -> return ()+      Just <$> (unifies "use in range expression" start_t =<< checkExp step)++  let unifyRange e = unifies "use in range expression" start_t =<< checkExp e+  end' <- case end of+    DownToExclusive e -> DownToExclusive <$> unifyRange e+    UpToExclusive e -> UpToExclusive <$> unifyRange e+    ToInclusive e -> ToInclusive <$> unifyRange e++  -- Special case some ranges to give them a known size.+  let dimFromBound = dimFromExp (SourceBound . bareExp)+  (dim, retext) <-+    case (isInt32 start', isInt32 <$> maybe_step', end') of+      (Just 0, Just (Just 1), UpToExclusive end'') ->+        dimFromBound end''+      (Just 0, Nothing, UpToExclusive end'') ->+        dimFromBound end''+      (Just 1, Just (Just 2), ToInclusive end'') ->+        dimFromBound end''+      _ -> do+        d <- newDimVar loc (Rigid RigidRange) "range_dim"+        return (NamedDim $ qualName d, Just d)++  t <- arrayOfM loc start_t (ShapeDecl [dim]) Unique+  let ret = (Info (t `setAliases` mempty), Info $ maybeToList retext)++  return $ Range start' maybe_step' end' ret loc++checkExp (Ascript e decl loc) = do+  (decl', e') <- checkAscript loc decl e id+  return $ Ascript e' decl' loc++checkExp (Coerce e decl _ loc) = do+  -- We instantiate the declared types with all dimensions as nonrigid+  -- fresh type variables, which we then use to unify with the type of+  -- 'e'.  This lets 'e' have whatever sizes it wants, but the overall+  -- type must still match.  Eventually we will throw away those sizes+  -- (they will end up being unified with various sizes in 'e', which+  -- is fine).+  (decl', e') <- checkAscript loc decl e anySizes++  -- Now we instantiate the declared type again, but this time we keep+  -- around the sizes as existentials.  This is the result of the+  -- ascription as a whole.  We use matchDims to obtain the aliasing+  -- of 'e'.+  (decl_t_rigid, ext) <-+    instantiateDimsInReturnType loc Nothing $ unInfo $ expandedType decl'++  t <- expTypeFully e'++  t' <- matchDims (const pure) t $ fromStruct decl_t_rigid++  return $ Coerce e' decl' (Info t', Info ext) loc++checkExp (BinOp (op, oploc) NoInfo (e1,_) (e2,_) NoInfo NoInfo loc) = do+  (op', ftype) <- lookupVar oploc op+  e1_arg <- checkArg e1+  e2_arg <- checkArg e2++  -- Note that the application to the first operand cannot fix any+  -- existential sizes, because it must by necessity be a function.+  (p1_t, rt, p1_ext, _) <- checkApply loc (Just op', 0) ftype e1_arg+  (p2_t, rt', p2_ext, retext) <- checkApply loc (Just op', 1) rt e2_arg++  return $ BinOp (op', oploc) (Info ftype)+    (argExp e1_arg, Info (toStruct p1_t, p1_ext))+    (argExp e2_arg, Info (toStruct p2_t, p2_ext))+    (Info rt') (Info retext) loc++checkExp (Project k e NoInfo loc) = do+  e' <- checkExp e+  t <- expType e'+  kt <- mustHaveField (mkUsage loc $ "projection of field " ++ quote (pretty k)) k t+  return $ Project k e' (Info kt) loc++checkExp (If e1 e2 e3 _ loc) =+  sequentially checkCond $ \e1' _ -> do+  ((e2', e3'), dflow) <- tapOccurences $ checkExp e2 `alternative` checkExp e3++  (brancht, retext) <- unifyBranches loc e2' e3'+  let t' = addAliases brancht (`S.difference` S.map AliasBound (allConsumed dflow))++  zeroOrderType (mkUsage loc "returning value of this type from 'if' expression")+    "type returned from branch" t'++  return $ If e1' e2' e3' (Info t', Info retext) loc++  where checkCond = do+          e1' <- checkExp e1+          let bool = Scalar $ Prim Bool+          e1_t <- toStruct <$> expType e1'+          onFailure (CheckingRequired [bool] e1_t) $+            unify (mkUsage (srclocOf e1') "use as 'if' condition") bool e1_t+          return e1'++checkExp (Parens e loc) =+  Parens <$> checkExp e <*> pure loc++checkExp (QualParens (modname, modnameloc) e loc) = do+  (modname',mod) <- lookupMod loc modname+  case mod of+    ModEnv env -> local (`withEnv` qualifyEnv modname' env) $ do+      e' <- checkExp e+      return $ QualParens (modname', modnameloc) e' loc+    ModFun{} ->+      typeError loc mempty $ "Module" <+> ppr modname <+> " is a parametric module."+  where qualifyEnv modname' env =+          env { envNameMap = M.map (qualify' modname') $ envNameMap env }+        qualify' modname' (QualName qs name) =+          QualName (qualQuals modname' ++ [qualLeaf modname'] ++ qs) name++checkExp (Var qn NoInfo loc) = do+  -- The qualifiers of a variable is divided into two parts: first a+  -- possibly-empty sequence of module qualifiers, followed by a+  -- possible-empty sequence of record field accesses.  We use scope+  -- information to perform the split, by taking qualifiers off the+  -- end until we find a module.++  (qn', t, fields) <- findRootVar (qualQuals qn) (qualLeaf qn)++  foldM checkField (Var qn' (Info t) loc) fields++  where findRootVar qs name =+          (whenFound <$> lookupVar loc (QualName qs name)) `catchError` notFound qs name++        whenFound (qn', t) = (qn', t, [])++        notFound qs name err+          | null qs = throwError err+          | otherwise = do+              (qn', t, fields) <- findRootVar (init qs) (last qs) `catchError`+                                  const (throwError err)+              return (qn', t, fields++[name])++        checkField e k = do+          t <- expType e+          let usage = mkUsage loc $ "projection of field " ++ quote (pretty k)+          kt <- mustHaveField usage k t+          return $ Project k e (Info kt) loc++checkExp (Negate arg loc) = do+  arg' <- require "numeric negation" anyNumberType =<< checkExp arg+  return $ Negate arg' loc++checkExp e@Apply{} = fst <$> checkApplyExp e++checkExp (LetPat pat e body _ loc) =+  sequentially (checkExp e) $ \e' e_occs -> do+    -- Not technically an ascription, but we want the pattern to have+    -- exactly the type of 'e'.+    t <- expType e'+    case anyConsumption e_occs of+      Just c ->+        let msg = "type computed with consumption at " ++ locStr (location c)+        in zeroOrderType (mkUsage loc "consumption in right-hand side of 'let'-binding") msg t+      _ -> return ()++    incLevel $ bindingPattern pat (Ascribed t) $ \pat' -> do+      body' <- checkExp body+      (body_t, retext) <-+        unscopeType loc (patternMap pat') =<< expTypeFully body'++      return $ LetPat pat' e' body' (Info body_t, Info retext) loc++checkExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body NoInfo loc) =+  sequentially (checkBinding (name, maybe_retdecl, tparams, params, e, loc)) $+  \(tparams', params', maybe_retdecl', rettype, _, e') closure -> do++    closure' <- lexicalClosure params' closure++    bindSpaced [(Term, name)] $ do+      name' <- checkName Term name loc++      let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt+          ftype = foldr (arrow . patternParam) rettype params'+          entry = BoundV Local tparams' $ ftype `setAliases` closure'+          bindF scope = scope { scopeVtable =+                                  M.insert name' entry $ scopeVtable scope+                              , scopeNameMap =+                                  M.insert (Term, name) (qualName name') $+                                  scopeNameMap scope }+      body' <- localScope bindF $ checkExp body++      -- We fake an ident here, but it's OK as it can't be a size+      -- anyway.+      let fake_ident = Ident name' (Info $ fromStruct ftype) noLoc+      (body_t, _) <-+        unscopeType loc (M.singleton name' fake_ident) =<<+        expTypeFully body'++      return $ LetFun name' (tparams', params', maybe_retdecl', Info rettype, e')+        body' (Info body_t) loc++checkExp (LetWith dest src idxes ve body NoInfo loc) =+  sequentially (checkIdent src) $ \src' _ -> do+  (t, _) <- newArrayType (srclocOf src) "src" $ length idxes+  unify (mkUsage loc "type of target array") t $ toStruct $ unInfo $ identType src'++  -- Need the fully normalised type here to get the proper aliasing information.+  src_t <- normTypeFully $ unInfo $ identType src'++  idxes' <- mapM checkDimIndex idxes+  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) idxes' =<< normTypeFully t++  unless (unique src_t) $+    typeError loc mempty $ "Source" <+> pquote (pprName (identName src)) <+>+    "has type" <+> ppr src_t <+> ", which is not unique."+  vtable <- asks $ scopeVtable . termScope+  forM_ (aliases src_t) $ \v ->+    case aliasVar v `M.lookup` vtable of+      Just (BoundV Local _ v_t)+        | not $ unique v_t ->+            typeError loc mempty $ "Source" <+> pquote (pprName (identName src)) <+>+            "aliases" <+> pquote (pprName (aliasVar v)) <+> ", which is not consumable."+      _ -> return ()++  sequentially (unifies "type of target array" (toStruct elemt) =<< checkExp ve) $ \ve' _ -> do+    ve_t <- expTypeFully ve'+    when (AliasBound (identName src') `S.member` aliases ve_t) $+      badLetWithValue loc++    bindingIdent dest (src_t `setAliases` S.empty) $ \dest' -> do+      body' <- consuming src' $ checkExp body+      (body_t, _) <-+        unscopeType loc (M.singleton (identName dest') dest') =<<+        expTypeFully body'+      return $ LetWith dest' src' idxes' ve' body' (Info body_t) loc++checkExp (Update src idxes ve loc) = do+  (t, _) <- newArrayType (srclocOf src) "src" $ length idxes+  idxes' <- mapM checkDimIndex idxes+  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) idxes' =<< normTypeFully t++  sequentially (checkExp ve >>= unifies "type of target array" elemt) $ \ve' _ ->+    sequentially (checkExp src >>= unifies "type of target array" t) $ \src' _ -> do++    src_t <- expTypeFully src'+    unless (unique src_t) $+      typeError loc mempty $ "Source" <+> pquote (ppr src) <+>+      "has type" <+> ppr src_t <+> ", which is not unique."++    let src_als = aliases src_t+    ve_t <- expTypeFully ve'+    unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue loc++    consume loc src_als+    return $ Update src' idxes' ve' loc++-- Record updates are a bit hacky, because we do not have row typing+-- (yet?).  For now, we only permit record updates where we know the+-- full type up to the field we are updating.+checkExp (RecordUpdate src fields ve NoInfo loc) = do+  src' <- checkExp src+  ve' <- checkExp ve+  a <- expTypeFully src'+  let usage = mkUsage loc "record update"+  r <- foldM (flip $ mustHaveField usage) a fields+  ve_t <- expType ve'+  let r' = anySizes $ toStruct r+      ve_t' = anySizes $ toStruct ve_t+  onFailure (CheckingRecordUpdate fields r' ve_t') $+    unify usage r' ve_t'+  maybe_a' <- onRecordField (const ve_t) fields <$> expTypeFully src'+  case maybe_a' of+    Just a' -> return $ RecordUpdate src' fields ve' (Info a') loc+    Nothing -> typeError loc mempty $+               "Full type of" </>+               indent 2 (ppr src) </>+               textwrap " is not known at this point.  Add a size annotation to the original record to disambiguate."++checkExp (Index e idxes _ loc) = do+  (t, _) <- newArrayType loc "e" $ length idxes+  e' <- unifies "being indexed at" t =<< checkExp e+  idxes' <- mapM checkDimIndex idxes+  -- XXX, the RigidSlice here will be overridden in sliceShape with a proper value.+  (t', retext) <-+    sliceShape (Just (loc, Rigid (RigidSlice Nothing ""))) idxes' =<<+    expTypeFully e'++  -- Remove aliases if the result is an overloaded type, because that+  -- will certainly not be aliased.+  t'' <- noAliasesIfOverloaded t'++  return $ Index e' idxes' (Info t'', Info retext) loc++checkExp (Unsafe e loc) =+  Unsafe <$> checkExp e <*> pure loc++checkExp (Assert e1 e2 NoInfo loc) = do+  e1' <- require "being asserted" [Bool] =<< checkExp e1+  e2' <- checkExp e2+  return $ Assert e1' e2' (Info (pretty e1)) loc++checkExp (Lambda params body rettype_te NoInfo loc) =+  removeSeminullOccurences $ noUnique $ incLevel $+  bindingParams [] params $ \_ params' -> do+    rettype_checked <- traverse checkTypeExp rettype_te+    let declared_rettype =+          case rettype_checked of Just (_, st, _) -> Just st+                                  Nothing -> Nothing+    (body', closure) <-+      tapOccurences $ checkFunBody params' body declared_rettype loc+    body_t <- expTypeFully body'++    params'' <- mapM updateTypes params'++    (rettype', rettype_st) <-+      case rettype_checked of+        Just (te, st, _) ->+          return (Just te, st)+        Nothing -> do+          ret <- inferReturnSizes params'' $ toStruct $+                 inferReturnUniqueness params'' body_t+          return (Nothing, ret)++    checkGlobalAliases params' body_t loc+    verifyFunctionParams Nothing params'++    closure' <- lexicalClosure params'' closure++    return $ Lambda params'' body' rettype' (Info (closure', rettype_st)) loc++  where+    -- Inferring the sizes of the return type of a lambda is a lot+    -- like let-generalisation.  We wish to remove any rigid sizes+    -- that were created when checking the body, except for those that+    -- are visible in types that existed before we entered the body,+    -- are parameters, or are used in parameters.+    inferReturnSizes params' ret = do+      cur_lvl <- curLevel+      let named (Named x, _) = Just x+          named (Unnamed, _) = Nothing+          param_names = mapMaybe (named . patternParam) params'+          pos_sizes =+            typeDimNamesPos (foldFunType (map patternStructType params') ret)+          hide k (lvl, _) =+            lvl >= cur_lvl && k `notElem` param_names && k `S.notMember` pos_sizes++      hidden_sizes <-+        S.fromList . M.keys . M.filterWithKey hide <$> getConstraints++      let onDim (NamedDim name)+            | not (qualLeaf name `S.member` hidden_sizes) = NamedDim name+            | otherwise = AnyDim+          onDim d = d++      return $ first onDim ret++checkExp (OpSection op _ loc) = do+  (op', ftype) <- lookupVar loc op+  return $ OpSection op' (Info ftype) loc++checkExp (OpSectionLeft op _ e _ _ loc) = do+  (op', ftype) <- lookupVar loc op+  e_arg <- checkArg e+  (t1, rt, argext, retext) <- checkApply loc (Just op', 0) ftype e_arg+  case rt of+    Scalar (Arrow _ _ t2 rettype) ->+      return $ OpSectionLeft op' (Info ftype) (argExp e_arg)+      (Info (toStruct t1, argext), Info $ toStruct t2) (Info rettype, Info retext) loc+    _ -> typeError loc mempty $+         "Operator section with invalid operator of type" <+> ppr ftype++checkExp (OpSectionRight op _ e _ NoInfo loc) = do+  (op', ftype) <- lookupVar loc op+  e_arg <- checkArg e+  case ftype of+    Scalar (Arrow as1 m1 t1 (Scalar (Arrow as2 m2 t2 ret))) -> do+      (t2', _, argext, _) <-+        checkApply loc (Just op', 1)+        (Scalar $ Arrow as2 m2 t2 $ Scalar $ Arrow as1 m1 t1 ret) e_arg+      return $ OpSectionRight op' (Info ftype) (argExp e_arg)+        (Info $ toStruct t1, Info (toStruct t2', argext)) (Info ret) loc+    _ -> typeError loc mempty $+         "Operator section with invalid operator of type" <+> ppr ftype++checkExp (ProjectSection fields NoInfo loc) = do+  a <- newTypeVar loc "a"+  let usage = mkUsage loc "projection at"+  b <- foldM (flip $ mustHaveField usage) a fields+  return $ ProjectSection fields (Info $ Scalar $ Arrow mempty Unnamed a b) loc++checkExp (IndexSection idxes NoInfo loc) = do+  (t, _) <- newArrayType loc "e" $ length idxes+  idxes' <- mapM checkDimIndex idxes+  (t', _) <- sliceShape Nothing idxes' t+  return $ IndexSection idxes' (Info $ fromStruct $ Scalar $ Arrow mempty Unnamed t t') loc++checkExp (DoLoop _ mergepat mergeexp form loopbody NoInfo loc) =+  sequentially (checkExp mergeexp) $ \mergeexp' _ -> do++  zeroOrderType (mkUsage (srclocOf mergeexp) "use as loop variable")+    "type used as loop variable" =<< expTypeFully mergeexp'++  -- The handling of dimension sizes is a bit intricate, but very+  -- similar to checking a function, followed by checking a call to+  -- it.  The overall procedure is as follows:+  --+  -- (1) All empty dimensions in the merge pattern are instantiated+  -- with nonrigid size variables.  All explicitly specified+  -- dimensions are preserved.+  --+  -- (2) The body of the loop is type-checked.  The result type is+  -- combined with the merge pattern type to determine which sizes are+  -- variant, and these are turned into size parameters for the merge+  -- pattern.+  --+  -- (3) We now conceptually have a function parameter type and return+  -- type.  We check that it can be called with the initial merge+  -- values as argument.  The result of this is the type of the loop+  -- as a whole.+  --+  -- (There is also a convergence loop for inferring uniqueness, but+  -- that's orthogonal to the size handling.)++  (merge_t, new_dims) <-+    instantiateEmptyArrayDims loc "loop" Nonrigid . -- dim handling (1)+    anySizes .+    (`setAliases` mempty) =<< expTypeFully mergeexp'++  -- dim handling (2)+  let checkLoopReturnSize mergepat' loopbody' = do+        loopbody_t <- expTypeFully loopbody'+        pat_t <- normTypeFully $ patternType mergepat'+        -- We are ignoring the dimensions here, because any mismatches+        -- should be turned into fresh size variables.+        onFailure (CheckingLoopBody (toStruct (anySizes pat_t)) (toStruct loopbody_t)) $+          expect (mkUsage (srclocOf loopbody) "matching loop body to loop pattern")+          (toStruct (anySizes pat_t))+          (toStruct loopbody_t)+        pat_t' <- normTypeFully pat_t+        loopbody_t' <- normTypeFully loopbody_t++        -- For each new_dims, figure out what they are instantiated+        -- with in the initial value.  This is used to determine+        -- whether a size is invariant because it always matches the+        -- initial instantiation of that size.+        let initSubst (NamedDim v, d) = Just (v, d)+            initSubst _ = Nothing+        init_substs <- M.fromList . mapMaybe initSubst . snd .+                       anyDimOnMismatch pat_t' <$>+                       expTypeFully mergeexp'++        -- Figure out which of the 'new_dims' dimensions are variant.+        -- This works because we know that each dimension from+        -- new_dims in the pattern is unique and distinct.+        --+        -- Our logic here is a bit reversed: the *mismatches* (from+        -- new_dims) are what we want to extract and turn into size+        -- parameters.+        let mismatchSubst (NamedDim v, d)+              | qualLeaf v `elem` new_dims =+                  case M.lookup v init_substs of+                    Just d'+                      | d' == d ->+                          return $ Just (qualLeaf v, SizeSubst d)+                    _ -> do tell [qualLeaf v]+                            return Nothing+            mismatchSubst _ = return Nothing++            (init_substs', sparams) =+              runWriter $ M.fromList . catMaybes <$> mapM mismatchSubst+              (snd $ anyDimOnMismatch pat_t' loopbody_t')++        -- Make sure that any of new_dims that are invariant will be+        -- replaced with the invariant size in the loop body.  Failure+        -- to do this can cause type annotations to still refer to+        -- new_dims.+        let dimToInit (v, SizeSubst d) =+              constrain v $ Size (Just d) (mkUsage loc "size of loop parameter")+            dimToInit _ =+              return ()+        mapM_ dimToInit $ M.toList init_substs'++        mergepat'' <- applySubst (`M.lookup` init_substs') <$> updateTypes mergepat'+        return (nub sparams, mergepat'')++  -- First we do a basic check of the loop body to figure out which of+  -- the merge parameters are being consumed.  For this, we first need+  -- to check the merge pattern, which requires the (initial) merge+  -- expression.+  --+  -- Play a little with occurences to ensure it does not look like+  -- none of the merge variables are being used.+  ((sparams, mergepat', form', loopbody'), bodyflow) <-+    case form of+      For i uboundexp -> do+        uboundexp' <- require "being the bound in a 'for' loop" anySignedType =<< checkExp uboundexp+        bound_t <- expTypeFully uboundexp'+        bindingIdent i bound_t $ \i' ->+          noUnique $ bindingPattern mergepat (Ascribed merge_t) $+          \mergepat' -> onlySelfAliasing $ tapOccurences $ do+            loopbody' <- noSizeEscape $ checkExp loopbody+            (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+            return (sparams,+                    mergepat'',+                    For i' uboundexp',+                    loopbody')++      ForIn xpat e -> do+        (arr_t, _) <- newArrayType (srclocOf e) "e" 1+        e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e+        t <- expTypeFully e'+        case t of+          _ | Just t' <- peelArray 1 t ->+                bindingPattern xpat (Ascribed t') $ \xpat' ->+                noUnique $ bindingPattern mergepat (Ascribed merge_t) $+                \mergepat' -> onlySelfAliasing $ tapOccurences $ do+                  loopbody' <- noSizeEscape $ checkExp loopbody+                  (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+                  return (sparams,+                          mergepat'',+                          ForIn xpat' e',+                          loopbody')+            | otherwise ->+                typeError (srclocOf e) mempty $+                "Iteratee of a for-in loop must be an array, but expression has type" <+>+                ppr t++      While cond ->+        noUnique $ bindingPattern mergepat (Ascribed merge_t) $ \mergepat' ->+        onlySelfAliasing $ tapOccurences $+        sequentially (checkExp cond >>=+                      unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool)) $ \cond' _ -> do+          loopbody' <- noSizeEscape $ checkExp loopbody+          (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+          return (sparams,+                  mergepat'',+                  While cond',+                  loopbody')++  mergepat'' <- do+    loop_t <- expTypeFully loopbody'+    convergePattern mergepat' (allConsumed bodyflow) loop_t $+      mkUsage (srclocOf loopbody') "being (part of) the result of the loop body"++  let consumeMerge (Id _ (Info pt) ploc) mt+        | unique pt = consume ploc $ aliases mt+      consumeMerge (TuplePattern pats _) t | Just ts <- isTupleRecord t =+        zipWithM_ consumeMerge pats ts+      consumeMerge (PatternParens pat _) t =+        consumeMerge pat t+      consumeMerge (PatternAscription pat _ _) t =+        consumeMerge pat t+      consumeMerge _ _ =+        return ()+  consumeMerge mergepat'' =<< expTypeFully mergeexp'++  -- dim handling (3)+  let sparams_anydim = M.fromList $ zip sparams $ repeat $ SizeSubst AnyDim+      loopt_anydims = applySubst (`M.lookup` sparams_anydim) $+                      patternType mergepat''+  (merge_t', _) <-+    instantiateEmptyArrayDims loc "loopres" Nonrigid $ toStruct loopt_anydims+  mergeexp_t <- toStruct <$> expTypeFully mergeexp'+  onFailure (CheckingLoopInitial (toStruct loopt_anydims) mergeexp_t) $+    unify (mkUsage (srclocOf mergeexp') "matching initial loop values to pattern")+    merge_t' mergeexp_t++  (loopt, retext) <- instantiateDimsInType loc RigidLoop loopt_anydims+  -- We set all of the uniqueness to be unique.  This is intentional,+  -- and matches what happens for function calls.  Those arrays that+  -- really *cannot* be consumed will alias something unconsumable,+  -- and will be caught that way.+  let bound_here = patternNames mergepat'' <> S.fromList sparams <> form_bound+      form_bound =+        case form' of+          For v _ -> S.singleton $ identName v+          ForIn forpat _ -> patternNames forpat+          While{} -> mempty+      loopt' = second (`S.difference` S.map AliasBound bound_here) $+               loopt `setUniqueness` Unique+++  -- Eliminate those new_dims that turned into sparams so it won't+  -- look like we have ambiguous sizes lying around.+  modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams++  return $ DoLoop sparams mergepat'' mergeexp' form' loopbody' (Info (loopt', retext)) loc++  where+    convergePattern pat body_cons body_t body_loc = do+      let consumed_merge = patternNames pat `S.intersection` body_cons++          uniquePat (Wildcard (Info t) wloc) =+            Wildcard (Info $ t `setUniqueness` Nonunique) wloc+          uniquePat (PatternParens p ploc) =+            PatternParens (uniquePat p) ploc+          uniquePat (Id name (Info t) iloc)+            | name `S.member` consumed_merge =+                let t' = t `setUniqueness` Unique `setAliases` mempty+                in Id name (Info t') iloc+            | otherwise =+                let t' = case t of Scalar Record{} -> t+                                   _               -> t `setUniqueness` Nonunique+                in Id name (Info t') iloc+          uniquePat (TuplePattern pats ploc) =+            TuplePattern (map uniquePat pats) ploc+          uniquePat (RecordPattern fs ploc) =+            RecordPattern (map (fmap uniquePat) fs) ploc+          uniquePat (PatternAscription p t ploc) =+            PatternAscription p t ploc+          uniquePat p@PatternLit{} = p+          uniquePat (PatternConstr n t ps ploc) =+            PatternConstr n t (map uniquePat ps) ploc++          -- Make the pattern unique where needed.+          pat' = uniquePat pat++      pat_t <- normTypeFully $ patternType pat'+      unless (toStructural body_t `subtypeOf` toStructural pat_t) $+        unexpectedType (srclocOf body_loc) (toStruct body_t) [toStruct pat_t]++      -- Check that the new values of consumed merge parameters do not+      -- alias something bound outside the loop, AND that anything+      -- returned for a unique merge parameter does not alias anything+      -- else returned.  We also update the aliases for the pattern.+      bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope+      let combAliases t1 t2 =+            case t1 of Scalar Record{} -> t1+                       _ -> t1 `addAliases` (<>aliases t2)++          checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t+            | unique pat_v_t,+              v:_ <- S.toList $+                     S.map aliasVar (aliases t) `S.intersection` bound_outside =+                lift $ typeError loc mempty $+                "Return value for loop parameter" <+>+                pquote (pprName pat_v) <+> "aliases" <+> pprName v <> "."++            | otherwise = do+                (cons,obs) <- get+                unless (S.null $ aliases t `S.intersection` cons) $+                  lift $ typeError loc mempty $+                  "Return value for loop parameter" <+>+                  pquote (pprName pat_v) <+>+                  "aliases other consumed loop parameter."+                when (unique pat_v_t &&+                      not (S.null (aliases t `S.intersection` (cons<>obs)))) $+                  lift $ typeError loc mempty $+                  "Return value for consuming loop parameter" <+>+                  pquote (pprName pat_v) <+> "aliases previously returned value."+                if unique pat_v_t+                  then put (cons<>aliases t, obs)+                  else put (cons, obs<>aliases t)++                return $ Id pat_v (Info (combAliases pat_v_t t)) patloc++          checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =+            return $ Wildcard (Info (combAliases pat_v_t t)) patloc++          checkMergeReturn (PatternParens p _) t =+            checkMergeReturn p t++          checkMergeReturn (PatternAscription p _ _) t =+            checkMergeReturn p t++          checkMergeReturn (RecordPattern pfs patloc) (Scalar (Record tfs)) =+            RecordPattern . M.toList <$> sequence pfs' <*> pure patloc+            where pfs' = M.intersectionWith checkMergeReturn+                         (M.fromList pfs) tfs++          checkMergeReturn (TuplePattern pats patloc) t+            | Just ts <- isTupleRecord t =+                TuplePattern+                <$> zipWithM checkMergeReturn pats ts+                <*> pure patloc++          checkMergeReturn p _ =+            return p++      (pat'', (pat_cons, _)) <-+        runStateT (checkMergeReturn pat' body_t) (mempty, mempty)++      let body_cons' = body_cons <> S.map aliasVar pat_cons+      if body_cons' == body_cons && patternType pat'' == patternType pat+        then return pat'+        else convergePattern pat'' body_cons' body_t body_loc++checkExp (Constr name es NoInfo loc) = do+  t <- newTypeVar loc "t"+  es' <- mapM checkExp es+  ets <- mapM expTypeFully es'+  mustHaveConstr (mkUsage loc "use of constructor") name t (toStruct <$> ets)+  -- A sum value aliases *anything* that went into its construction.+  let als = foldMap aliases ets+  return $ Constr name es' (Info $ fromStruct t `addAliases` (<>als)) loc++checkExp (Match e cs _ loc) =+  sequentially (checkExp e) $ \e' _ -> do+    mt <- expTypeFully e'+    (cs', t, retext) <- checkCases mt cs+    zeroOrderType (mkUsage loc "being returned 'match'")+      "type returned from pattern match" t+    return $ Match e' cs' (Info t, Info retext) loc++checkCases :: PatternType+           -> NE.NonEmpty (CaseBase NoInfo Name)+           -> TermTypeM (NE.NonEmpty (CaseBase Info VName), PatternType, [VName])+checkCases mt rest_cs =+  case NE.uncons rest_cs of+    (c, Nothing) -> do+      (c', t, retext) <- checkCase mt c+      return (c' NE.:| [], t, retext)+    (c, Just cs) -> do+      (((c', c_t, _), (cs', cs_t, _)), dflow) <-+        tapOccurences $ checkCase mt c `alternative` checkCases mt cs+      (brancht, retext) <- unifyBranchTypes (srclocOf c) c_t cs_t+      let t = addAliases brancht+              (`S.difference` S.map AliasBound (allConsumed dflow))+      return (NE.cons c' cs', t, retext)++checkCase :: PatternType -> CaseBase NoInfo Name+          -> TermTypeM (CaseBase Info VName, PatternType, [VName])+checkCase mt (CasePat p e loc) =+  bindingPattern p (Ascribed mt) $ \p' -> do+    e' <- checkExp e+    (t, retext) <- unscopeType loc (patternMap p') =<< expTypeFully e'+    return (CasePat p' e' loc, t, retext)++-- | An unmatched pattern. Used in in the generation of+-- unmatched pattern warnings by the type checker.+data Unmatched p = UnmatchedNum p [ExpBase Info VName]+                 | UnmatchedBool p+                 | UnmatchedConstr p+                 | Unmatched p+                 deriving (Functor, Show)++instance Pretty (Unmatched (PatternBase Info VName)) where+  ppr um = case um of+      (UnmatchedNum p nums) -> ppr' p <+> "where p is not one of" <+> ppr nums+      (UnmatchedBool p)     -> ppr' p+      (UnmatchedConstr p)     -> ppr' p+      (Unmatched p)         -> ppr' p+    where+      ppr' (PatternAscription p t _) = ppr p <> ":" <+> ppr t+      ppr' (PatternParens p _)       = parens $ ppr' p+      ppr' (Id v _ _)                = pprName v+      ppr' (TuplePattern pats _)     = parens $ commasep $ map ppr' pats+      ppr' (RecordPattern fs _)      = braces $ commasep $ map ppField fs+        where ppField (name, t)      = text (nameToString name) <> equals <> ppr' t+      ppr' Wildcard{}                = "_"+      ppr' (PatternLit e _ _)        = ppr e+      ppr' (PatternConstr n _ ps _)   = "#" <> ppr n <+> sep (map ppr' ps)++unpackPat :: Pattern -> [Maybe Pattern]+unpackPat Wildcard{} = [Nothing]+unpackPat (PatternParens p _) = unpackPat p+unpackPat Id{} = [Nothing]+unpackPat (TuplePattern ps _) = Just <$> ps+unpackPat (RecordPattern fs _) = Just . snd <$> sortFields (M.fromList fs)+unpackPat (PatternAscription p _ _) = unpackPat p+unpackPat p@PatternLit{} = [Just p]+unpackPat p@PatternConstr{} = [Just p]++wildPattern :: Pattern -> Int -> Unmatched Pattern -> Unmatched Pattern+wildPattern (TuplePattern ps loc) pos um = wildTuple <$> um+  where wildTuple p = TuplePattern (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc+        ps' = map wildOut ps+        wildOut p = Wildcard (Info (patternType p)) (srclocOf p)+wildPattern (RecordPattern fs loc) pos um = wildRecord <$> um+  where wildRecord p =+          RecordPattern (take (pos - 1) fs' ++ [(fst (fs!!(pos - 1)), p)] ++ drop pos fs') loc+        fs' = map wildOut fs+        wildOut (f,p) = (f, Wildcard (Info (patternType p)) (srclocOf p))+wildPattern (PatternAscription p _ _) pos um = wildPattern p pos um+wildPattern (PatternParens p _) pos um = wildPattern p pos um+wildPattern (PatternConstr n t ps loc) pos um = wildConstr <$> um+  where wildConstr p = PatternConstr n t (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc+        ps' = map wildOut ps+        wildOut p = Wildcard (Info (patternType p)) (srclocOf p)+wildPattern _ _ um = um++checkUnmatched :: Exp -> TermTypeM ()+checkUnmatched e = void $ checkUnmatched' e >> astMap tv e+  where checkUnmatched' (Match _ cs _ loc) =+          let ps = fmap (\(CasePat p _ _) -> p) cs+          in case unmatched id $ NE.toList ps of+              []  -> return ()+              ps' -> typeError loc mempty $+                     "Unmatched cases in match expression:" </>+                     indent 2 (stack (map ppr ps'))+        checkUnmatched' _ = return ()+        tv = ASTMapper { mapOnExp =+                           \e' -> checkUnmatched' e' >> return e'+                       , mapOnName        = pure+                       , mapOnQualName    = pure+                       , mapOnStructType  = pure+                       , mapOnPatternType = pure+                       }++-- | A data type for constructor patterns.  This is used to make the+-- code for detecting unmatched constructors cleaner, by separating+-- the constructor-pattern cases from other cases.+data ConstrPat = ConstrPat { constrName :: Name+                           , constrType :: PatternType+                           , constrPayload :: [Pattern]+                           , constrSrcLoc :: SrcLoc+                           }++-- Be aware of these fishy equality instances!++instance Eq ConstrPat where+  ConstrPat c1 _ _ _ == ConstrPat c2 _ _ _ = c1 == c2++instance Ord ConstrPat where+  ConstrPat c1 _ _ _ `compare` ConstrPat c2 _ _ _ = c1 `compare` c2++unmatched :: (Unmatched Pattern -> Unmatched Pattern) -> [Pattern] -> [Unmatched Pattern]+unmatched hole orig_ps+  | p:_ <- orig_ps,+    sameStructure labeledCols = do+    (i, cols) <- labeledCols+    let hole' = if isConstr p then hole else hole . wildPattern p i+    case sequence cols of+      Nothing -> []+      Just cs+        | all isPatternLit cs  -> map hole' $ localUnmatched cs+        | otherwise            -> unmatched hole' cs+  | otherwise = []++  where labeledCols = zip [1..] $ transpose $ map unpackPat orig_ps++        localUnmatched :: [Pattern] -> [Unmatched Pattern]+        localUnmatched [] = []+        localUnmatched ps'@(p':_) =+          case patternType p'  of+            Scalar (Sum cs'') ->+              -- We now know that we are matching a sum type, and thus+              -- that all patterns ps' are constructors (checked by+              -- 'all isPatternLit' before this function is called).+              let constrs   = M.keys cs''+                  matched   = mapMaybe constr ps'+                  unmatched' = map (UnmatchedConstr . buildConstr cs'') $+                               constrs \\ map constrName matched+             in case unmatched' of+                [] ->+                  let constrGroups   = group (sort matched)+                      removedConstrs = mapMaybe stripConstrs constrGroups+                      transposed     = (fmap . fmap) transpose removedConstrs+                      findUnmatched (pc, trans) = do+                        col <- trans+                        case col of+                          []           -> []+                          ((i, _):_) -> unmatched (wilder i pc) (map snd col)+                      wilder i pc s = (`PatternParens` noLoc) <$> wildPattern pc i s+                  in concatMap findUnmatched transposed+                _ -> unmatched'+            Scalar (Prim t) | not (any idOrWild ps') ->+              -- We now know that we are matching a sum type, and thus+              -- that all patterns ps' are literals (checked by 'all+              -- isPatternLit' before this function is called).+                case t of+                  Bool ->+                    let matched = nub $ mapMaybe (pExp >=> bool) $ filter isPatternLit ps'+                    in map (UnmatchedBool . buildBool (Scalar (Prim t))) $ [True, False] \\ matched+                  _ ->+                    let matched = mapMaybe pExp $ filter isPatternLit ps'+                    in [UnmatchedNum (buildId (Info $ Scalar $ Prim t) "p") matched]+            _ -> []++        isConstr PatternConstr{} = True+        isConstr (PatternParens p _) = isConstr p+        isConstr _ = False+++        stripConstrs :: [ConstrPat] -> Maybe (Pattern, [[(Int, Pattern)]])+        stripConstrs (pc@ConstrPat{} : cs') = Just (unConstr pc, stripConstr pc : map stripConstr cs')+        stripConstrs [] = Nothing++        stripConstr :: ConstrPat -> [(Int, Pattern)]+        stripConstr (ConstrPat _ _  ps' _) = zip [1..] ps'++        sameStructure [] = True+        sameStructure (x:xs) = all (\y -> length y == length x' ) xs'+          where (x':xs') = map snd (x:xs)++        pExp (PatternLit e' _ _) = Just e'+        pExp _ = Nothing++        constr (PatternConstr c (Info t) ps loc) = Just $ ConstrPat c t ps loc+        constr (PatternParens p _) = constr p+        constr (PatternAscription p' _ _)  = constr p'+        constr _ = Nothing++        unConstr p =+          PatternConstr (constrName p) (Info $ constrType p) (constrPayload p) (constrSrcLoc p)++        isPatternLit PatternLit{} = True+        isPatternLit (PatternAscription p' _ _) = isPatternLit p'+        isPatternLit (PatternParens p' _)  = isPatternLit p'+        isPatternLit PatternConstr{} = True+        isPatternLit _ = False++        idOrWild Id{} = True+        idOrWild Wildcard{} = True+        idOrWild (PatternAscription p' _ _) = idOrWild p'+        idOrWild (PatternParens p' _) = idOrWild p'+        idOrWild _ = False++        bool (Literal (BoolValue b) _ ) = Just b+        bool _ = Nothing++        buildConstr m c =+          let t      = Scalar $ Sum m+              cs     = m M.! c+              wildCS = map (\ct -> Wildcard (Info ct) noLoc) cs+          in if null wildCS+               then PatternConstr c (Info t) [] noLoc+               else PatternParens (PatternConstr c (Info t) wildCS noLoc) noLoc+        buildBool t b =+          PatternLit (Literal (BoolValue b) noLoc) (Info (addSizes t)) noLoc+        buildId t n =+          -- The VName tag here will never be used since the value+          -- exists exclusively for printing warnings.+          Id (VName (nameFromString n) (-1)) t noLoc++checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident+checkIdent (Ident name _ loc) = do+  (QualName _ name', vt) <- lookupVar loc (qualName name)+  return $ Ident name' (Info vt) loc++checkDimIndex :: DimIndexBase NoInfo Name -> TermTypeM DimIndex+checkDimIndex (DimFix i) =+  DimFix <$> (unifies "use as index" (Scalar $ Prim $ Signed Int32) =<< checkExp i)+checkDimIndex (DimSlice i j s) =+  DimSlice <$> check i <*> check j <*> check s+  where check = maybe (return Nothing) $+                fmap Just . unifies "use as index" (Scalar $ Prim $ Signed Int32) <=< checkExp++sequentially :: TermTypeM a -> (a -> Occurences -> TermTypeM b) -> TermTypeM b+sequentially m1 m2 = do+  (a, m1flow) <- collectOccurences m1+  (b, m2flow) <- collectOccurences $ m2 a m1flow+  occur $ m1flow `seqOccurences` m2flow+  return b++type Arg = (Exp, PatternType, Occurences, SrcLoc)++argExp :: Arg -> Exp+argExp (e, _, _, _) = e++argType :: Arg -> PatternType+argType (_, t, _, _) = t++checkArg :: UncheckedExp -> TermTypeM Arg+checkArg arg = do+  (arg', dflow) <- collectOccurences $ checkExp arg+  arg_t <- expType arg'+  return (arg', arg_t, dflow, srclocOf arg')++instantiateDimsInType :: SrcLoc -> RigidSource+                      -> TypeBase (DimDecl VName) als+                      -> TermTypeM (TypeBase (DimDecl VName) als, [VName])+instantiateDimsInType tloc rsrc =+  instantiateEmptyArrayDims tloc "d" $ Rigid rsrc++instantiateDimsInReturnType :: SrcLoc -> Maybe (QualName VName)+                            -> TypeBase (DimDecl VName) als+                            -> TermTypeM (TypeBase (DimDecl VName) als, [VName])+instantiateDimsInReturnType tloc fname =+  instantiateEmptyArrayDims tloc "ret" $ Rigid $ RigidRet fname++-- Some information about the function/operator we are trying to+-- apply, and how many arguments it has previously accepted.  Used for+-- generating nicer type errors.+type ApplyOp = (Maybe (QualName VName), Int)++checkApply :: SrcLoc -> ApplyOp -> PatternType -> Arg+           -> TermTypeM (PatternType, PatternType, Maybe VName, [VName])+checkApply loc (fname, _)+           (Scalar (Arrow as pname tp1 tp2))+           (argexp, argtype, dflow, argloc) =+  onFailure (CheckingApply fname argexp (toStruct tp1) (toStruct argtype)) $ do+  expect (mkUsage argloc "use as function argument") (toStruct tp1) (toStruct argtype)++  -- Perform substitutions of instantiated variables in the types.+  tp1' <- normTypeFully tp1+  (tp2', ext) <- instantiateDimsInReturnType loc fname =<< normTypeFully tp2+  argtype' <- normTypeFully argtype++  -- Check whether this would produce an impossible return type.+  let (_, tp2_paramdims, _) = dimUses $ toStruct tp2'+  case filter (`S.member` tp2_paramdims) ext of+    [] -> return ()+    ext_paramdims -> do+      let onDim (NamedDim qn)+            | qualLeaf qn `elem` ext_paramdims = AnyDim+          onDim d = d+      typeError loc mempty $+        "Anonymous size would appear in function parameter of return type:" </>+        indent 2 (ppr (first onDim tp2')) </>+        textwrap "This is usually because a higher-order function is used with functional arguments that return anonymous sizes, which are then used as parameters of other function arguments."++  occur [observation as loc]++  checkOccurences dflow+  occurs <- consumeArg argloc argtype' (diet tp1')++  case anyConsumption dflow of+    Just c ->+      let msg = "type of expression with consumption at " ++ locStr (location c)+      in zeroOrderType (mkUsage argloc "potential consumption in expression") msg tp1+    _ -> return ()++  occur $ dflow `seqOccurences` occurs+  (argext, parsubst) <-+    case pname of+      Named pname' -> do+        (d, argext) <- sizeSubst tp1' argexp+        return (argext,+                (`M.lookup` M.singleton pname' (SizeSubst d)))+      _ -> return (Nothing, const Nothing)+  let tp2'' = applySubst parsubst $ returnType tp2' (diet tp1') argtype'++  return (tp1', tp2'', argext, ext)+  where sizeSubst (Scalar (Prim (Signed Int32))) e = dimFromArg fname e+        sizeSubst _ _ = return (AnyDim, Nothing)++checkApply loc fname tfun@(Scalar TypeVar{}) arg = do+  tv <- newTypeVar loc "b"+  unify (mkUsage loc "use as function") (toStruct tfun) $+    Scalar $ Arrow mempty Unnamed (toStruct (argType arg)) tv+  tfun' <- normPatternType tfun+  checkApply loc fname tfun' arg++checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do+  let fname' = maybe "expression" (pquote . ppr) fname++  typeError loc mempty $+    if prev_applied == 0+    then "Cannot apply" <+> fname' <+> "as function, as it has type:" </>+         indent 2 (ppr ftype)+    else "Cannot apply" <+> fname' <+> "to argument #" <> ppr (prev_applied+1) <+>+         pquote (shorten $ pretty $ flatten $ ppr argexp) <> "," <+/>+         "as" <+> fname' <+> "only takes" <+> ppr prev_applied <+>+         arguments <> "."+  where arguments | prev_applied == 1 = "argument"+                  | otherwise = "arguments"++isInt32 :: Exp -> Maybe Int32+isInt32 (Literal (SignedValue (Int32Value k')) _) = Just $ fromIntegral k'+isInt32 (IntLit k' _ _) = Just $ fromInteger k'+isInt32 (Negate x _) = negate <$> isInt32 x+isInt32 _ = Nothing++maybeDimFromExp :: Exp -> Maybe (DimDecl VName)+maybeDimFromExp (Var v _ _) = Just $ NamedDim v+maybeDimFromExp (Parens e _) = maybeDimFromExp e+maybeDimFromExp (QualParens _ e _) = maybeDimFromExp e+maybeDimFromExp e = ConstDim . fromIntegral <$> isInt32 e++dimFromExp :: (Exp -> SizeSource) -> Exp -> TermTypeM (DimDecl VName, Maybe VName)+dimFromExp rf (Parens e _) = dimFromExp rf e+dimFromExp rf (QualParens _ e _) = dimFromExp rf e+dimFromExp rf e+  | Just d <- maybeDimFromExp e =+      return (d, Nothing)+  | otherwise =+      extSize (srclocOf e) $ rf e++dimFromArg :: Maybe (QualName VName) -> Exp -> TermTypeM (DimDecl VName, Maybe VName)+dimFromArg fname = dimFromExp $ SourceArg (FName fname) . bareExp++-- | @returnType ret_type arg_diet arg_type@ gives result of applying+-- an argument the given types to a function with the given return+-- type, consuming the argument with the given diet.+returnType :: PatternType+           -> Diet+           -> PatternType+           -> PatternType+returnType (Array _ Unique et shape) _ _ =+  Array mempty Unique et shape+returnType (Array als Nonunique et shape) d arg =+  Array (als<>arg_als) Unique et shape -- Intentional!+  where arg_als = aliases $ maskAliases arg d+returnType (Scalar (Record fs)) d arg =+  Scalar $ Record $ fmap (\et -> returnType et d arg) fs+returnType (Scalar (Prim t)) _ _ =+  Scalar $ Prim t+returnType (Scalar (TypeVar _ Unique t targs)) _ _ =+  Scalar $ TypeVar mempty Unique t targs+returnType (Scalar (TypeVar als Nonunique t targs)) d arg =+  Scalar $ TypeVar (als<>arg_als) Unique t targs -- Intentional!+  where arg_als = aliases $ maskAliases arg d+returnType (Scalar (Arrow _ v t1 t2)) d arg =+  Scalar $ Arrow als v (t1 `setAliases` mempty) (t2 `setAliases` als)+  where als = aliases $ maskAliases arg d+returnType (Scalar (Sum cs)) d arg =+  Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs++-- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from+-- the parts of @t@ that are denoted as consumed by the 'Diet' @d@.+maskAliases :: Monoid as =>+               TypeBase shape as+            -> Diet+            -> TypeBase shape as+maskAliases t Consume = t `setAliases` mempty+maskAliases t Observe = t+maskAliases (Scalar (Record ets)) (RecordDiet ds) =+  Scalar $ Record $ M.intersectionWith maskAliases ets ds+maskAliases t FuncDiet{} = t+maskAliases _ _ = error "Invalid arguments passed to maskAliases."++consumeArg :: SrcLoc -> PatternType -> Diet -> TermTypeM [Occurence]+consumeArg loc (Scalar (Record ets)) (RecordDiet ds) =+  concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds)+consumeArg loc (Array _ Nonunique _ _) Consume =+  typeError loc mempty "Consuming parameter passed non-unique argument."+consumeArg loc (Scalar (TypeVar _ Nonunique _ _)) Consume =+  typeError loc mempty "Consuming parameter passed non-unique argument."+consumeArg loc (Scalar (Arrow _ _ t1 _)) (FuncDiet d _)+  | not $ contravariantArg t1 d =+      typeError loc mempty "Non-consuming higher-order parameter passed consuming argument."+  where contravariantArg (Array _ Unique _ _) Observe =+          False+        contravariantArg (Scalar (TypeVar _ Unique _ _)) Observe =+          False+        contravariantArg (Scalar (Record ets)) (RecordDiet ds) =+          and (M.intersectionWith contravariantArg ets ds)+        contravariantArg (Scalar (Arrow _ _ tp tr)) (FuncDiet dp dr) =+          contravariantArg tp dp && contravariantArg tr dr+        contravariantArg _ _ =+          True+consumeArg loc (Scalar (Arrow _ _ _ t2)) (FuncDiet _ pd) =+  consumeArg loc t2 pd+consumeArg loc at Consume = return [consumption (aliases at) loc]+consumeArg loc at _       = return [observation (aliases at) loc]++checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)+checkOneExp e = fmap fst . runTermTypeM $ do+  e' <- checkExp e+  let t = toStruct $ typeOf e'+  (tparams, _, _, _) <-+    letGeneralise (nameFromString "<exp>") (srclocOf e) [] [] t+  e'' <- updateTypes e'+  fixOverloadedTypes+  checkUnmatched e''+  causalityCheck e''+  return (tparams, e'')++-- Verify that all sum type constructors and empty array literals have+-- a size that is known (rigid or a type parameter).  This is to+-- ensure that we can actually determine their shape at run-time.+causalityCheck :: Exp -> TermTypeM ()+causalityCheck binding_body = do+  constraints <- getConstraints++  let checkCausality what known t loc+        | (d,dloc):_ <- mapMaybe (unknown constraints known) $+                        S.toList $ mustBeExplicit $ toStruct t =+            Just $ lift $ causality what loc d dloc t+        | otherwise = Nothing++      checkParamCausality known p =+        checkCausality (ppr p) known (patternType p) (srclocOf p)++      onExp :: S.Set VName -> Exp+            -> StateT (S.Set VName) (Either TypeError) Exp++      onExp known (Var v (Info t) loc)+        | Just bad <- checkCausality (pquote (ppr v)) known t loc =+            bad++      onExp known (ArrayLit [] (Info t) loc)+        | Just bad <- checkCausality "empty array" known t loc =+            bad++      onExp known (Lambda params _ _ _ _)+        | bad : _ <- mapMaybe (checkParamCausality known) params =+            bad++      onExp known e@(LetPat _ bindee_e body_e (_, Info ext) _) = do+        sequencePoint known bindee_e body_e ext+        return e++      onExp known e@(Apply f arg (Info (_, p)) (_, Info ext) _) = do+        sequencePoint known arg f $ maybeToList p ++ ext+        return e++      onExp known e = do+        recurse known e++        case e of+          BinOp _ _ (_, Info (_, xp)) (_, Info (_, yp)) _ (Info ext) _ ->+            modify (<>S.fromList (catMaybes [xp,yp]++ext))+          DoLoop _ _ _ _ _ (Info (_, ext)) _ ->+            modify (<>S.fromList ext)+          If _ _ _ (_, Info ext) _ ->+            modify (<>S.fromList ext)+          Index _ _ (_, Info ext) _ ->+            modify (<>S.fromList ext)+          Match _ _ (_, Info ext) _ ->+            modify (<>S.fromList ext)+          Range _ _ _ (_, Info ext) _ ->+            modify (<>S.fromList ext)+          _ ->+            return ()++        return e++      recurse known = void . astMap mapper+        where mapper = identityMapper { mapOnExp = onExp known }++      sequencePoint known x y ext = do+        new_known <- lift $ execStateT (onExp known x) mempty+        void $ onExp (new_known<>known) y+        modify ((new_known<>S.fromList ext)<>)++  either throwError (const $ return ()) $+    evalStateT (onExp mempty binding_body) mempty+  where unknown constraints known v = do+          guard $ v `S.notMember` known+          loc <- unknowable constraints v+          return (v,loc)++        unknowable constraints v =+          case snd <$> M.lookup v constraints of+            Just (UnknowableSize loc _) -> Just loc+            _                           -> Nothing++        causality what loc d dloc t =+          Left $ TypeError loc mempty $+          "Causality check: size" <+/> pquote (pprName d) <+/>+          "needed for type of" <+> what <> colon </>+          indent 2 (ppr t) </>+          "But" <+> pquote (pprName d) <+> "is computed at" <+/>+          text (locStrRel loc dloc) <> "." </>+          "" </>+          "Hint:" <+>+          align (textwrap "Bind the expression producing" <+> pquote (pprName d) <+>+                 "with 'let' beforehand.")++-- | Type-check a top-level (or module-level) function definition.+-- Despite the name, this is also used for checking constant+-- definitions, by treating them as 0-ary functions.+checkFunDef :: (Name, Maybe UncheckedTypeExp,+                [UncheckedTypeParam], [UncheckedPattern],+                UncheckedExp, SrcLoc)+            -> TypeM (VName, [TypeParam], [Pattern], Maybe (TypeExp VName),+                      StructType, [VName], Exp)+checkFunDef (fname, maybe_retdecl, tparams, params, body, loc) =+  fmap fst $ runTermTypeM $ do+  (tparams', params', maybe_retdecl', rettype', retext, body') <-+    checkBinding (fname, maybe_retdecl, tparams, params, body, loc)++  -- Since this is a top-level function, we also resolve overloaded+  -- types, using either defaults or complaining about ambiguities.+  fixOverloadedTypes++  -- Then replace all inferred types in the body and parameters.+  body'' <- updateTypes body'+  params'' <- updateTypes params'+  maybe_retdecl'' <- traverse updateTypes maybe_retdecl'+  rettype'' <- normTypeFully rettype'++  -- Check if pattern matches are exhaustive and yield+  -- errors if not.+  checkUnmatched body''++  -- Check if the function body can actually be evaluated.+  causalityCheck body''++  bindSpaced [(Term, fname)] $ do+    fname' <- checkName Term fname loc+    when (nameToString fname `elem` doNotShadow) $+      typeError loc mempty $+      "The" <+> pprName fname <+> "operator may not be redefined."++    return (fname', tparams', params'', maybe_retdecl'', rettype'', retext, body'')++-- | This is "fixing" as in "setting them", not "correcting them".  We+-- only make very conservative fixing.+fixOverloadedTypes :: TermTypeM ()+fixOverloadedTypes = getConstraints >>= mapM_ fixOverloaded . M.toList . M.map snd+  where fixOverloaded (v, Overloaded ots usage)+          | Signed Int32 `elem` ots = do+              unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $+                Scalar $ Prim $ Signed Int32+              warn usage "Defaulting ambiguous type to i32."+          | FloatType Float64 `elem` ots = do+              unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $+                Scalar $ Prim $ FloatType Float64+              warn usage "Defaulting ambiguous type to f64."+          | otherwise =+              typeError usage mempty $+              "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 $+          "Type of expression is ambiguous." </>+          "Add a type annotation to disambiguate the type."++        fixOverloaded (_, Equality usage) =+          typeError usage mempty $+          "Type is ambiguous (must be equality type)." </>+          "Add a type annotation to disambiguate the type."++        fixOverloaded (_, HasFields fs usage) =+          typeError usage mempty $+          "Type is ambiguous.  Must be record with fields:" </>+          indent 2 (stack $ map field $ M.toList fs) </>+          "Add a type annotation to disambiguate the type."+          where field (l, t) = ppr l <> colon <+> align (ppr t)++        fixOverloaded (_, HasConstrs cs usage) =+          typeError usage mempty $+          "Type is ambiguous (must be a sum type with constructors:" <+>+          ppr (Sum cs) <> ")." </>+          "Add a type annotation to disambiguate the type."++        fixOverloaded (_, Size Nothing usage) =+          typeError usage mempty "Size is ambiguous."++        fixOverloaded _ = return ()++hiddenParamNames :: [Pattern] -> Names+hiddenParamNames params = hidden+  where param_all_names = mconcat $ map patternNames params+        named (Named x, _) = Just x+        named (Unnamed, _) = Nothing+        param_names =+          S.fromList $ mapMaybe (named . patternParam) params+        hidden = param_all_names `S.difference` param_names++inferredReturnType :: SrcLoc -> [Pattern] -> PatternType -> TermTypeM StructType+inferredReturnType loc params t =+  -- The inferred type may refer to names that are bound by the+  -- parameter patterns, but which will not be visible in the type.+  -- These we must turn into fresh type variables, which will be+  -- existential in the return type.+  fmap (toStruct . fst) $+  unscopeType loc+  (M.filterWithKey (const . (`S.member` hidden)) $ foldMap patternMap params) $+  inferReturnUniqueness params t+  where hidden = hiddenParamNames params++checkBinding :: (Name, Maybe UncheckedTypeExp,+                 [UncheckedTypeParam], [UncheckedPattern],+                 UncheckedExp, SrcLoc)+             -> TermTypeM ([TypeParam], [Pattern], Maybe (TypeExp VName),+                           StructType, [VName], Exp)+checkBinding (fname, maybe_retdecl, tparams, params, body, loc) =+  noUnique $ incLevel $ bindingParams tparams params $ \tparams' params' -> do+    when (null params && any isSizeParam tparams) $+      typeError loc mempty+      "Size parameters are only allowed on bindings that also have value parameters."++    maybe_retdecl' <- forM maybe_retdecl $ \retdecl -> do+      (retdecl', ret_nodims, _) <- checkTypeExp retdecl+      (ret, _) <- instantiateEmptyArrayDims loc "funret" Nonrigid ret_nodims+      return (retdecl', ret)++    body' <- checkFunBody params' body+             (snd <$> maybe_retdecl')+             (maybe loc srclocOf maybe_retdecl)++    params'' <- mapM updateTypes params'+    body_t <- expTypeFully body'++    (maybe_retdecl'', rettype) <- case maybe_retdecl' of+      Just (retdecl', ret) -> do+        let rettype_structural = toStructural ret+        checkReturnAlias rettype_structural params'' body_t++        when (null params) $ nothingMustBeUnique loc rettype_structural++        ret' <- normTypeFully ret++        return (Just retdecl', ret')++      Nothing+        | null params ->+            return (Nothing, toStruct $ body_t `setUniqueness` Nonunique)+        | otherwise -> do+            body_t' <- inferredReturnType loc params'' body_t+            return (Nothing, body_t')++    verifyFunctionParams (Just fname) params''++    (tparams'', params''', rettype'', retext) <-+      letGeneralise fname loc tparams' params'' rettype++    checkGlobalAliases params'' body_t loc++    return (tparams'', params''', maybe_retdecl'', rettype'', retext, body')++  where -- | Check that unique return values do not alias a+        -- non-consumed parameter.+        checkReturnAlias rettp params' =+          foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp+        checkReturnAlias' params' seen (Unique, names)+          | any (`S.member` S.map snd seen) $ S.toList names =+              uniqueReturnAliased fname loc+          | otherwise = do+              notAliasingParam params' names+              return $ seen `S.union` tag Unique names+        checkReturnAlias' _ seen (Nonunique, names)+          | any (`S.member` seen) $ S.toList $ tag Unique names =+            uniqueReturnAliased fname loc+          | otherwise = return $ seen `S.union` tag Nonunique names++        notAliasingParam params' names =+          forM_ params' $ \p ->+          let consumedNonunique p' =+                not (unique $ unInfo $ identType p') && (identName p' `S.member` names)+          in case find consumedNonunique $ S.toList $ patternIdents p of+               Just p' ->+                 returnAliased fname (baseName $ identName p') loc+               Nothing ->+                 return ()++        tag u = S.map (u,)++        returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =+          concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2+        returnAliasing expected got =+          [(uniqueness expected, S.map aliasVar $ aliases got)]++-- | Extract all the shape names that occur in positive position+-- (roughly, left side of an arrow) in a given type.+typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName+typeDimNamesPos (Scalar (Arrow _ _ t1 t2)) = onParam t1 <> typeDimNamesPos t2+  where onParam :: TypeBase (DimDecl VName) als -> S.Set VName+        onParam (Scalar Arrow{}) = mempty+        onParam (Scalar (Record fs)) = mconcat $ map onParam $ M.elems fs+        onParam (Scalar (TypeVar _ _ _ targs)) = mconcat $ map onTypeArg targs+        onParam t = typeDimNames t+        onTypeArg (TypeArgDim (NamedDim d) _) = S.singleton $ qualLeaf d+        onTypeArg (TypeArgDim _ _) = mempty+        onTypeArg (TypeArgType t _) = onParam t+typeDimNamesPos _ = mempty++checkGlobalAliases :: [Pattern] -> PatternType -> SrcLoc -> TermTypeM ()+checkGlobalAliases params body_t loc = do+  vtable <- asks $ scopeVtable . termScope+  let isLocal v = case v `M.lookup` vtable of+                    Just (BoundV Local _ _) -> True+                    _ -> False+  let als = filter (not . isLocal) $ S.toList $+            boundArrayAliases body_t `S.difference`+            foldMap patternNames params+  case als of+    v:_ | not $ null params ->+      typeError loc mempty $+      "Function result aliases the free variable " <>+      pquote (pprName v) <> "." </>+      "Use" <+> pquote "copy" <+> "to break the aliasing."+    _ ->+      return ()++inferReturnUniqueness :: [Pattern] -> PatternType -> PatternType+inferReturnUniqueness params t =+  let forbidden = aliasesMultipleTimes t+      uniques = uniqueParamNames params+      delve (Scalar (Record fs)) =+        Scalar $ Record $ M.map delve fs+      delve t'+        | all (`S.member` uniques) (boundArrayAliases t'),+          not $ any ((`S.member` forbidden) . aliasVar) (aliases t') =+            t'+        | otherwise =+            t' `setUniqueness` Nonunique+  in delve t++-- An alias inhibits uniqueness if it is used in disjoint values.+aliasesMultipleTimes :: PatternType -> Names+aliasesMultipleTimes = S.fromList . map fst . filter ((>1) . snd) . M.toList . delve+  where delve (Scalar (Record fs)) =+          foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs+        delve t =+          M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1::Int)++uniqueParamNames :: [Pattern] -> Names+uniqueParamNames =+  S.map identName+  . S.filter (unique . unInfo . identType)+  . foldMap patternIdents++boundArrayAliases :: PatternType -> S.Set VName+boundArrayAliases (Array als _ _ _) = boundAliases als+boundArrayAliases (Scalar Prim{}) = mempty+boundArrayAliases (Scalar (Record fs)) = foldMap boundArrayAliases fs+boundArrayAliases (Scalar (TypeVar als _ _ _)) = boundAliases als+boundArrayAliases (Scalar Arrow{}) = mempty+boundArrayAliases (Scalar (Sum fs)) =+  mconcat $ concatMap (map boundArrayAliases) $ M.elems fs++-- | The set of in-scope variables that are being aliased.+boundAliases :: Aliasing -> S.Set VName+boundAliases = S.map aliasVar . S.filter bound+  where bound AliasBound{} = True+        bound AliasFree{} = False++nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()+nothingMustBeUnique loc = check+  where check (Array _ Unique _ _) = bad+        check (Scalar (TypeVar _ Unique _ _)) = bad+        check (Scalar (Record fs)) = mapM_ check fs+        check _ = return ()+        bad = typeError loc mempty "A top-level constant cannot have a unique type."++-- | Verify certain restrictions on function parameters, and bail out+-- on dubious constructions.+--+-- These restrictions apply to all functions (anonymous or otherwise).+-- Top-level functions have further restrictions that are checked+-- during let-generalisation.+verifyFunctionParams :: Maybe Name -> [Pattern] -> TermTypeM ()+verifyFunctionParams fname params =+  onFailure (CheckingParams fname) $+  verifyParams (foldMap patternNames params) =<< mapM updateTypes params+  where+    verifyParams forbidden (p:ps)+      | d:_ <- S.toList $ patternDimNames p `S.intersection` forbidden =+          typeError p mempty $+          "Parameter" <+> pquote (ppr p) <+/>+          "refers to size" <+> pquote (pprName d) <> comma <+/>+          textwrap "which will not be accessible to the caller" <> comma <+/>+          textwrap "possibly because it is nested in a tuple or record." <+/>+          textwrap "Consider ascribing an explicit type that does not reference " <>+          pquote (pprName d) <> "."+      | otherwise = verifyParams forbidden' ps+      where forbidden' =+              case patternParam p of+                (Named v, _) -> forbidden `S.difference` S.singleton v+                _            -> forbidden++    verifyParams _ [] = return ()++-- Returns the sizes of the immediate type produced,+-- the sizes of parameter types, and the sizes of return types.+dimUses :: StructType -> (Names, Names, Names)+dimUses = execWriter . traverseDims f+  where f PosImmediate (NamedDim v) = tell (S.singleton (qualLeaf v), mempty, mempty)+        f PosParam (NamedDim v) = tell (mempty, S.singleton (qualLeaf v), mempty)+        f PosReturn (NamedDim v) = tell (mempty, mempty, S.singleton (qualLeaf v))+        f _ _ = return ()++-- | Find at all type variables in the given type that are covered by+-- the constraints, and produce type parameters that close over them.+--+-- The passed-in list of type parameters is always prepended to the+-- produced list of type parameters.+closeOverTypes :: Name -> SrcLoc+               -> [TypeParam] -> [StructType] -> StructType+               -> Constraints -> TermTypeM ([TypeParam], StructType, [VName])+closeOverTypes defname defloc tparams paramts ret substs = do+  (more_tparams, retext) <- partitionEithers . catMaybes <$>+                            mapM closeOver (M.toList $ M.map snd to_close_over)+  let retToAnyDim v = do guard $ v `S.member` ret_sizes+                         UnknowableSize{} <- snd <$> M.lookup v substs+                         Just $ SizeSubst AnyDim+  return (tparams ++ more_tparams,+          applySubst retToAnyDim ret,+          retext)+  where t = foldFunType paramts ret+        to_close_over = M.filterWithKey (\k _ -> k `S.member` visible) substs+        visible = typeVars t <> typeDimNames t++        (produced_sizes, param_sizes, ret_sizes) = dimUses t++        -- Avoid duplicate type parameters.+        closeOver (k, _)+          | k `elem` map typeParamName tparams =+              return Nothing+        closeOver (k, NoConstraint l usage) =+          return $ Just $ Left $ TypeParamType l k $ srclocOf usage+        closeOver (k, ParamType l loc) =+          return $ Just $ Left $ TypeParamType l k loc+        closeOver (k, Size Nothing usage) =+          return $ Just $ Left $ TypeParamDim k $ srclocOf usage+        closeOver (k, UnknowableSize _ _)+          | k `S.member` param_sizes = do+              notes <- dimNotes defloc $ NamedDim $ qualName k+              typeError defloc notes $+                "Unknowable size" <+> pquote (pprName k) <+>+                "imposes constraint on type of" <+>+                pquote (pprName defname) <>+                ", which is inferred as:" </>+                indent 2 (ppr t)+          | k `S.member` produced_sizes =+              return $ Just $ Right k+        closeOver (_, _) =+          return Nothing++letGeneralise :: Name -> SrcLoc+              -> [TypeParam] -> [Pattern] -> StructType+              -> TermTypeM ([TypeParam], [Pattern], StructType, [VName])+letGeneralise defname defloc tparams params rettype =+  onFailure (CheckingLetGeneralise defname) $ do+  now_substs <- getConstraints++  -- Candidates for let-generalisation are those type variables that+  --+  -- (1) were not known before we checked this function, and+  --+  -- (2) are not used in the (new) definition of any type variables+  -- known before we checked this function.+  --+  -- (3) are not referenced from an overloaded type (for example,+  -- are the element types of an incompletely resolved record type).+  -- This is a bit more restrictive than I'd like, and SML for+  -- example does not have this restriction.+  --+  -- Criteria (1) and (2) is implemented by looking at the binding+  -- level of the type variables.+  let keep_type_vars = overloadedTypeVars now_substs++  cur_lvl <- curLevel+  let candidate k (lvl, _) = (k `S.notMember` keep_type_vars) && lvl >= cur_lvl+      new_substs = M.filterWithKey candidate now_substs++  (tparams', rettype', retext) <-+    closeOverTypes defname defloc tparams+    (map patternStructType params) rettype new_substs++  rettype'' <- updateTypes rettype'++  let used_sizes = foldMap typeDimNames $+                   rettype'' : map patternStructType params+  case filter ((`S.notMember` used_sizes) . typeParamName) $+       filter isSizeParam tparams' of+    [] -> return ()+    tp:_ -> typeError defloc mempty $+            "Size parameter" <+> pquote (ppr tp) <+> "unused."++  -- We keep those type variables that were not closed over by+  -- let-generalisation.+  modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams'++  return (tparams', params, rettype'', retext)++checkFunBody :: [Pattern]+             -> UncheckedExp+             -> Maybe StructType+             -> SrcLoc+             -> TermTypeM Exp+checkFunBody params body maybe_rettype loc = do+  body' <- noSizeEscape $ checkExp body++  -- Unify body return type with return annotation, if one exists.+  case maybe_rettype of+    Just rettype -> do+      (rettype_withdims, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid rettype++      body_t <- expTypeFully body'+      -- We need to turn any sizes provided by "hidden" parameter+      -- names into existential sizes instead.+      let hidden = hiddenParamNames params+      (body_t', _) <- unscopeType loc+                      (M.filterWithKey (const . (`S.member` hidden)) $+                       foldMap patternMap params)+                      body_t++      let usage = mkUsage (srclocOf body) "return type annotation"+      onFailure (CheckingReturn rettype (toStruct body_t')) $+        expect usage rettype_withdims $ toStruct body_t'++      -- We also have to make sure that uniqueness matches.  This is done+      -- explicitly, because uniqueness is ignored by unification.+      rettype' <- normTypeFully rettype+      body_t'' <- normTypeFully rettype -- Substs may have changed.+      unless (body_t'' `subtypeOf` anySizes rettype') $+        typeError (srclocOf body) mempty $+        "Body type" </> indent 2 (ppr body_t'') </>+        "is not a subtype of annotated type" </>+        indent 2 (ppr rettype')++    Nothing -> return ()++  return body'++--- Consumption++occur :: Occurences -> TermTypeM ()+occur = tell++-- | Proclaim that we have made read-only use of the given variable.+observe :: Ident -> TermTypeM ()+observe (Ident nm (Info t) loc) =+  let als = AliasBound nm `S.insert` aliases t+  in occur [observation als loc]++-- | Proclaim that we have written to the given variable.+consume :: SrcLoc -> Aliasing -> TermTypeM ()+consume loc als = do+  vtable <- asks $ scopeVtable . termScope+  let consumable v = case M.lookup v vtable of+                       Just (BoundV Local _ t)+                         | arrayRank t > 0 -> unique t+                         | otherwise -> True+                       _ -> False+  case filter (not . consumable) $ map aliasVar $ S.toList als of+    v:_ -> typeError loc mempty $+           "Attempt to consume variable" <+> pquote (pprName v)+           <> ", which is not allowed."+    [] -> occur [consumption als loc]++-- | Proclaim that we have written to the given variable, and mark+-- accesses to it and all of its aliases as invalid inside the given+-- computation.+consuming :: Ident -> TermTypeM a -> TermTypeM a+consuming (Ident name (Info t) loc) m = do+  consume loc $ AliasBound name `S.insert` aliases t+  localScope consume' m+  where consume' scope =+          scope { scopeVtable = M.insert name (WasConsumed loc) $ scopeVtable scope }++collectOccurences :: TermTypeM a -> TermTypeM (a, Occurences)+collectOccurences m = pass $ do+  (x, dataflow) <- listen m+  return ((x, dataflow), const mempty)++tapOccurences :: TermTypeM a -> TermTypeM (a, Occurences)+tapOccurences = listen++removeSeminullOccurences :: TermTypeM a -> TermTypeM a+removeSeminullOccurences = censor $ filter $ not . seminullOccurence++checkIfUsed :: Occurences -> Ident -> TermTypeM ()+checkIfUsed occs v+  | not $ identName v `S.member` allOccuring occs,+    not $ "_" `isPrefixOf` prettyName (identName v) =+      warn (srclocOf v) $ "Unused variable " ++ quote (pretty $ baseName $ identName v) ++ "."+  | otherwise =+      return ()++alternative :: TermTypeM a -> TermTypeM b -> TermTypeM (a,b)+alternative m1 m2 = pass $ do+  (x, occurs1) <- listen $ noSizeEscape m1+  (y, occurs2) <- listen $ noSizeEscape m2+  checkOccurences occurs1+  checkOccurences occurs2+  let usage = occurs1 `altOccurences` occurs2+  return ((x, y), const usage)++-- | Make all bindings nonunique.+noUnique :: TermTypeM a -> TermTypeM a+noUnique = localScope (\scope -> scope { scopeVtable = M.map set $ scopeVtable scope})+  where set (BoundV l tparams t)    = BoundV l tparams $ t `setUniqueness` Nonunique+        set (OverloadedF ts pts rt) = OverloadedF ts pts rt+        set EqualityF               = EqualityF+        set (WasConsumed loc)       = WasConsumed loc++onlySelfAliasing :: TermTypeM a -> TermTypeM a+onlySelfAliasing = localScope (\scope -> scope { scopeVtable = M.mapWithKey set $ scopeVtable scope})+  where set k (BoundV l tparams t)    = BoundV l tparams $+                                        t `addAliases` S.intersection (S.singleton (AliasBound k))+        set _ (OverloadedF ts pts rt) = OverloadedF ts pts rt+        set _ EqualityF               = EqualityF+        set _ (WasConsumed loc)       = WasConsumed loc++arrayOfM :: (Pretty (ShapeDecl dim), Monoid as) =>+            SrcLoc+         -> TypeBase dim as -> ShapeDecl dim -> Uniqueness+         -> TermTypeM (TypeBase dim as)+arrayOfM loc t shape u = do+  zeroOrderType (mkUsage loc "use as array element") "type used in array" t+  return $ arrayOf t shape u++updateTypes :: ASTMappable e => e -> TermTypeM e+updateTypes = astMap tv+  where tv = ASTMapper { mapOnExp         = astMap tv+                       , mapOnName        = pure+                       , mapOnQualName    = pure+                       , mapOnStructType  = normTypeFully+                       , mapOnPatternType = normTypeFully+                       }
src/Language/Futhark/TypeChecker/Types.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Futhark.TypeChecker.Types   ( checkTypeExp   , checkTypeDecl@@ -11,9 +13,6 @@   , checkTypeParams   , typeParamToArg -  , typeExpUses-  , checkShapeParamUses-   , TypeSub(..)   , TypeSubs   , substituteTypes@@ -24,8 +23,8 @@   ) where +import Control.Monad.Identity import Control.Monad.Reader-import Control.Monad.Except import Control.Monad.State import Data.Bifunctor import Data.List@@ -35,6 +34,8 @@  import Language.Futhark import Language.Futhark.TypeChecker.Monad+import Language.Futhark.Traversals+import Futhark.Util.Pretty  -- | @unifyTypes uf t1 t2@ attempts to unify @t1@ and @t2@.  If -- unification cannot happen, 'Nothing' is returned, otherwise a type@@ -98,14 +99,11 @@ subuniqueOf _ _              = True  checkTypeDecl :: MonadTypeChecker m =>-                 [TypeParam]-              -> TypeDeclBase NoInfo Name+                 TypeDeclBase NoInfo Name               -> m (TypeDeclBase Info VName, Liftedness)-checkTypeDecl tps (TypeDecl t NoInfo) = do+checkTypeDecl (TypeDecl t NoInfo) = do   checkForDuplicateNamesInType t   (t', st, l) <- checkTypeExp t-  let (pts, ret) = unfoldFunType st-  checkShapeParamUses tps $ pts ++ [ret]   return (TypeDecl t' $ Info st, l)  checkTypeExp :: MonadTypeChecker m =>@@ -115,9 +113,9 @@   (name', ps, t, l) <- lookupType loc name   case ps of     [] -> return (TEVar name' loc, t, l)-    _  -> throwError $ TypeError loc $-          "Type constructor " ++ quote (unwords (pretty name : map pretty ps)) ++-          " used without any arguments."+    _  -> typeError loc mempty $+          "Type constructor" <+> pquote (spread (ppr name : map ppr ps)) <+>+          "used without any arguments." checkTypeExp (TETuple ts loc) = do   (ts', ts_s, ls) <- unzip3 <$> mapM checkTypeExp ts   return (TETuple ts' loc, tupleRecord ts_s, foldl' max Unlifted ls)@@ -125,7 +123,7 @@   -- Check for duplicate field names.   let field_names = map fst fs   unless (sort field_names == sort (nub field_names)) $-    throwError $ TypeError loc $ "Duplicate record fields in " ++ pretty t+    typeError loc mempty $ "Duplicate record fields in" <+> ppr t <> "."    fs_ts_ls <- traverse checkTypeExp $ M.fromList fs   let fs' = fmap (\(x,_,_) -> x) fs_ts_ls@@ -140,11 +138,13 @@   case (l, arrayOf st (ShapeDecl [d'']) Nonunique) of     (Unlifted, st') -> return (TEArray t' d' loc, st', Unlifted)     (SizeLifted, _) ->-      throwError $ TypeError loc $-      "Cannot create array with elements of size-lifted type " ++ quote (pretty t) ++ " (might cause irregular array)."+      typeError loc mempty $+      "Cannot create array with elements of size-lifted type" <+> pquote (ppr t) <+/>+      "(might cause irregular array)."     (Lifted, _) ->-      throwError $ TypeError loc $-      "Cannot create array with elements of lifted type " ++ quote (pretty t) ++ " (might contain function)."+      typeError loc mempty $+      "Cannot create array with elements of lifted type" <+> pquote (ppr t) <+/>+      "(might contain function)."   where checkDimExp DimExpAny =           return (DimExpAny, AnyDim)         checkDimExp (DimExpConst k dloc) =@@ -182,9 +182,9 @@   (tname, tname_loc, targs) <- rootAndArgs ote   (tname', ps, t, l) <- lookupType tloc tname   if length ps /= length targs-  then throwError $ TypeError tloc $-       "Type constructor " ++ quote (pretty tname) ++ " requires " ++ show (length ps) ++-       " arguments, but provided " ++ show (length targs) ++ "."+  then typeError tloc mempty $+       "Type constructor" <+> pquote (ppr tname) <+> "requires" <+> ppr (length ps) <+>+       "arguments, but provided" <+> ppr (length targs) <+> "."   else do     (targs', substs) <- unzip <$> zipWithM checkArgApply ps targs     return (foldl (\x y -> TEApply x y tloc) (TEVar tname' tname_loc) targs',@@ -196,8 +196,8 @@         rootAndArgs (TEVar qn loc) = return (qn, loc, [])         rootAndArgs (TEApply op arg _) = do (op', loc, args) <- rootAndArgs op                                             return (op', loc, args++[arg])-        rootAndArgs te' = throwError $ TypeError (srclocOf te') $-                          "Type '" ++ pretty te' ++ "' is not a type constructor."+        rootAndArgs te' = typeError (srclocOf te') mempty $+                          "Type" <+> pquote (ppr te') <+> "is not a type constructor."          checkArgApply (TypeParamDim pv _) (TypeArgExpDim (DimExpNamed v dloc) loc) = do           v' <- checkNamedDim loc v@@ -216,16 +216,16 @@                   M.singleton pv $ TypeSub $ TypeAbbr l [] st)          checkArgApply p a =-          throwError $ TypeError tloc $ "Type argument " ++ pretty a ++-          " not valid for a type parameter " ++ pretty p+          typeError tloc mempty $ "Type argument" <+> ppr a <+>+          "not valid for a type parameter" <+> ppr p <> "."  checkTypeExp t@(TESum cs loc) = do   let constructors = map fst cs   unless (sort constructors == sort (nub constructors)) $-    throwError $ TypeError loc $ "Duplicate constructors in " ++ pretty t+    typeError loc mempty $ "Duplicate constructors in" <+> ppr t -  unless (length constructors <= 256) $-    throwError $ TypeError loc "Sum types must have 256 or fewer constructors."+  unless (length constructors < 256) $+    typeError loc mempty "Sum types must have less than 256 constructors."    cs_ts_ls <- (traverse . traverse) checkTypeExp $ M.fromList cs   let cs'  = (fmap . fmap) (\(x,_,_) -> x) cs_ts_ls@@ -253,8 +253,9 @@           already <- gets $ M.lookup v           case already of             Just prev_loc ->-              lift $ throwError $ TypeError loc $-              "Name " ++ quote (pretty v) ++ " also bound at " ++ locStr prev_loc+              lift $ typeError loc mempty $+              "Name" <+> pquote (ppr v) <+> "also bound at" <+>+              text (locStr prev_loc) <> "."             Nothing ->               modify $ M.insert v loc @@ -268,8 +269,9 @@ checkForDuplicateNamesInType = check mempty   where check seen (TEArrow (Just v) t1 t2 loc)           | Just prev_loc <- M.lookup v seen =-              throwError $ TypeError loc $-              "Name " ++ quote (pretty v) ++ " also bound at " ++ locStr prev_loc+              typeError loc mempty $+              text "Name" <+> pquote (ppr v) <+>+              "also bound at" <+> text (locStr prev_loc) <> "."           | otherwise =               check seen' t1 >> check seen' t2               where seen' = M.insert v loc seen@@ -286,38 +288,6 @@         check _ TEArray{} = return ()         check _ TEVar{} = return () --- | Ensure that every shape parameter is used in positive position at--- least once before being used in negative position.-checkShapeParamUses :: MonadTypeChecker m =>-                       [TypeParam] -> [StructType] -> m ()-checkShapeParamUses tps ts = do-  uses <- foldM onType mempty ts-  mapM_ (checkIfUsed uses) tps-  where onDim pos (NamedDim d) =-          modify $ M.insertWith min (qualLeaf d) pos-        onDim _ _ = return ()--        onType uses t = do-          let uses' = execState (traverseDims onDim t) uses-          mapM_ (checkUsage uses') tps-          return uses'--        checkUsage uses (TypeParamDim pv loc)-          | Just pos <- M.lookup pv uses,-            pos `elem` [PosParam, PosReturn] =-              throwError $ TypeError loc $-                "Shape parameter " ++ quote (prettyName pv) ++-                " must first be used in" ++-                " a positive position (non-functional parameter)."-        checkUsage _ _ = return ()--        checkIfUsed uses (TypeParamDim pv loc)-          | M.member pv uses = return ()-          | otherwise =-              throwError $ TypeError loc $ "Size parameter " ++-              quote (prettyName pv) ++ " unused."-        checkIfUsed _ _ = return ()- checkTypeParams :: MonadTypeChecker m =>                    [TypeParamBase Name]                 -> ([TypeParamBase VName] -> m a)@@ -332,9 +302,9 @@           seen <- gets $ M.lookup (ns,v)           case seen of             Just prev ->-              throwError $ TypeError loc $-              "Type parameter " ++ quote (pretty v) ++-              " previously defined at " ++ locStr prev ++ "."+              lift $ typeError loc mempty $+              text "Type parameter" <+> pquote (ppr v) <+>+              "previously defined at" <+> text (locStr prev) <> "."             Nothing -> do               modify $ M.insert (ns,v) loc               lift $ checkName ns v loc@@ -349,27 +319,7 @@ typeParamToArg (TypeParamDim v ploc) =   TypeArgDim (NamedDim $ qualName v) ploc typeParamToArg (TypeParamType _ v ploc) =-  TypeArgType (Scalar (TypeVar () Nonunique (typeName v) [])) ploc---- | Return the shapes used in a given type expression in positive and negative--- position, respectively.-typeExpUses :: TypeExp VName -> ([VName], [VName])-typeExpUses (TEVar _ _) = mempty-typeExpUses (TETuple tes _) = foldMap typeExpUses tes-typeExpUses (TERecord fs _) = foldMap (typeExpUses . snd) fs-typeExpUses (TEArray te d _) = typeExpUses te <> dimExpUses d-typeExpUses (TEUnique te _) = typeExpUses te-typeExpUses (TEApply te targ _) = typeExpUses te <> typeArgUses targ-  where typeArgUses (TypeArgExpDim d _) = dimExpUses d-        typeArgUses (TypeArgExpType tae) = typeExpUses tae-typeExpUses (TEArrow _ t1 t2 _) =-  let (pos, neg) = typeExpUses t1 <> typeExpUses t2-  in (mempty, pos <> neg)-typeExpUses (TESum cs _) = foldMap (mconcat . fmap typeExpUses . snd) cs--dimExpUses :: DimExp VName -> ([VName], [VName])-dimExpUses (DimExpNamed v _) = ([qualLeaf v], [])-dimExpUses _ = mempty+  TypeArgType (Scalar $ TypeVar () Nonunique (typeName v) []) ploc  data TypeSub = TypeSub TypeBinding              | DimSub (DimDecl VName)@@ -428,45 +378,59 @@ -- substitution (but which is certainly an overloaded primitive -- type!).  The latter is used to remove aliases from types that are -- yet-unknown but that we know cannot carry aliases (see issue #682).-data Subst t = Subst t | PrimSubst+data Subst t = Subst t | PrimSubst | SizeSubst (DimDecl VName)+  deriving (Show)  instance Functor Subst where   fmap f (Subst t) = Subst $ f t   fmap _ PrimSubst = PrimSubst+  fmap _ (SizeSubst v) = SizeSubst v  -- | Class of types which allow for substitution of types with no -- annotations for type variable names. class Substitutable a where-  applySubst :: (VName -> Maybe (Subst (TypeBase () ()))) -> a -> a+  applySubst :: (VName -> Maybe (Subst StructType)) -> a -> a -instance Substitutable (TypeBase () ()) where+instance Substitutable (TypeBase (DimDecl VName) ()) where   applySubst = substTypesAny -instance Substitutable (TypeBase () Aliasing) where+instance Substitutable (TypeBase (DimDecl VName) Aliasing) where   applySubst = substTypesAny . (fmap (fmap fromStruct).) -instance Substitutable (TypeBase (DimDecl VName) ()) where-  applySubst = substTypesAny . (fmap (fmap vacuousShapeAnnotations).)+instance Substitutable (DimDecl VName) where+  applySubst f (NamedDim (QualName _ v))+    | Just (SizeSubst d) <- f v = d+  applySubst _ d = d -instance Substitutable (TypeBase (DimDecl VName) Aliasing) where-  applySubst = substTypesAny . (fmap (fmap (vacuousShapeAnnotations . fromStruct)).)+instance Substitutable d => Substitutable (ShapeDecl d) where+  applySubst f = fmap $ applySubst f +instance Substitutable Pattern where+  applySubst f = runIdentity . astMap mapper+    where mapper = ASTMapper { mapOnExp = return+                             , mapOnName = return+                             , mapOnQualName = return+                             , mapOnStructType = return . applySubst f+                             , mapOnPatternType = return . applySubst f+                             }+ -- | Perform substitutions, from type names to types, on a type. Works -- regardless of what shape and uniqueness information is attached to the type.-substTypesAny :: (ArrayDim dim, Monoid as) =>-                 (VName -> Maybe (Subst (TypeBase dim as)))-              -> TypeBase dim as -> TypeBase dim as+substTypesAny :: Monoid as =>+                 (VName -> Maybe (Subst (TypeBase (DimDecl VName) as)))+              -> TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as substTypesAny lookupSubst ot = case ot of   Array als u et shape ->-    arrayOf (substTypesAny lookupSubst' (Scalar et)) shape u `setAliases` als+    arrayOf (substTypesAny lookupSubst' (Scalar et))+    (applySubst lookupSubst' shape) u `setAliases` als   Scalar (Prim t) -> Scalar $ Prim t   -- We only substitute for a type variable with no arguments, since   -- type parameters cannot have higher kind.   Scalar (TypeVar als u v targs) ->     case lookupSubst $ qualLeaf (qualNameFromTypeName v) of-      Just (Subst t) -> t `setUniqueness` u `addAliases` (<>als)+      Just (Subst t) -> substTypesAny lookupSubst $ t `setUniqueness` u `addAliases` (<>als)       Just PrimSubst -> Scalar $ TypeVar mempty u v $ map subsTypeArg targs-      Nothing -> Scalar $ TypeVar als u v $ map subsTypeArg targs+      _ -> Scalar $ TypeVar als u v $ map subsTypeArg targs   Scalar (Record ts) -> Scalar $ Record $ fmap (substTypesAny lookupSubst) ts   Scalar (Arrow als v t1 t2) ->     Scalar $ Arrow als v (substTypesAny lookupSubst t1) (substTypesAny lookupSubst t2)@@ -475,6 +439,7 @@    where subsTypeArg (TypeArgType t loc) =           TypeArgType (substTypesAny lookupSubst' t) loc-        subsTypeArg t = t+        subsTypeArg (TypeArgDim v loc) =+          TypeArgDim (applySubst lookupSubst' v) loc          lookupSubst' = fmap (fmap $ second (const ())) . lookupSubst
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Futhark.TypeChecker.Unify   ( Constraint(..)   , Usage@@ -7,10 +9,13 @@   , mkUsage'   , Level   , Constraints-  , lookupSubst   , MonadUnify(..)-  , BreadCrumb(..)-  , typeError+  , Rigidity(..)+  , RigidSource(..)+  , BreadCrumbs+  , noBreadCrumbs+  , hasNoBreadCrumbs+  , dimNotes   , mkTypeVarName    , zeroOrderType@@ -18,28 +23,76 @@   , mustHaveField   , mustBeOneOf   , equalityType-  , normaliseType+  , normType+  , normPatternType+  , normTypeFully+  , instantiateEmptyArrayDims    , unify+  , expect+  , unifyMostCommon+  , anyDimOnMismatch   , doUnification   ) where  import Control.Monad.Except+import Control.Monad.Writer hiding (Sum)+import Control.Monad.RWS.Strict hiding (Sum) import Control.Monad.State+import Data.Bifoldable (biany) import Data.List import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S -import Language.Futhark+import Language.Futhark hiding (unifyDims) import Language.Futhark.TypeChecker.Monad hiding (BoundV) import Language.Futhark.TypeChecker.Types-import Futhark.Util.Pretty (Pretty)+import Futhark.Util.Pretty hiding (empty) +-- | A piece of information that describes what process the type+-- checker currently performing.  This is used to give better error+-- messages for unification errors.+data BreadCrumb = MatchingTypes StructType StructType+                | MatchingFields [Name]+                | MatchingConstructor Name+                | Matching Doc++instance Pretty BreadCrumb where+  ppr (MatchingTypes t1 t2) =+    "When matching type" </> indent 2 (ppr t1) </>+    "with" </> indent 2 (ppr t2)+  ppr (MatchingFields fields) =+    "When matching types of record field" <+>+    pquote (mconcat $ punctuate "." $ map ppr fields) <> dot+  ppr (MatchingConstructor c) =+    "When matching types of constructor" <+> pquote (ppr c) <> dot+  ppr (Matching s) =+    s++newtype BreadCrumbs = BreadCrumbs [BreadCrumb]++noBreadCrumbs :: BreadCrumbs+noBreadCrumbs = BreadCrumbs []++hasNoBreadCrumbs :: BreadCrumbs -> Bool+hasNoBreadCrumbs (BreadCrumbs xs) = null xs++breadCrumb :: BreadCrumb -> BreadCrumbs -> BreadCrumbs+breadCrumb (MatchingFields xs) (BreadCrumbs (MatchingFields ys : bcs)) =+  BreadCrumbs $ MatchingFields (ys++xs) : bcs+breadCrumb bc (BreadCrumbs bcs) =+  BreadCrumbs $ bc : bcs++instance Pretty BreadCrumbs where+  ppr (BreadCrumbs []) = mempty+  ppr (BreadCrumbs bcs) = line <> stack (map ppr bcs)+ -- | A usage that caused a type constraint. data Usage = Usage (Maybe String) SrcLoc+  deriving (Show)  mkUsage :: SrcLoc -> String -> Usage mkUsage = flip (Usage . Just)@@ -47,9 +100,9 @@ mkUsage' :: SrcLoc -> Usage mkUsage' = Usage Nothing -instance Show Usage where-  show (Usage Nothing loc) = "use at " ++ locStr loc-  show (Usage (Just s) loc) = s ++ " at " ++ locStr loc+instance Pretty Usage where+  ppr (Usage Nothing loc) = "use at " <> textwrap (locStr loc)+  ppr (Usage (Just s) loc) = textwrap s <+/> "at" <+> textwrap (locStr loc)  instance Located Usage where   locOf (Usage _ loc) = locOf loc@@ -61,21 +114,33 @@  data Constraint = NoConstraint Liftedness Usage                 | ParamType Liftedness SrcLoc-                | Constraint (TypeBase () ()) Usage+                | Constraint StructType Usage                 | Overloaded [PrimType] Usage-                | HasFields (M.Map Name (TypeBase () ())) Usage+                | HasFields (M.Map Name StructType) Usage                 | Equality Usage-                | HasConstrs (M.Map Name [TypeBase () ()]) Usage+                | HasConstrs (M.Map Name [StructType]) Usage+                | ParamSize SrcLoc+                | Size (Maybe (DimDecl VName)) Usage+                  -- ^ Is not actually a type, but a term-level size,+                  -- possibly already set to something specific.+                | UnknowableSize SrcLoc RigidSource+                  -- ^ A size that does not unify with anything -+                  -- created from the result of applying a function+                  -- whose return size is existential, or otherwise+                  -- hiding a size.                 deriving Show  instance Located Constraint where   locOf (NoConstraint _ usage) = locOf usage-  locOf (ParamType _ loc) = locOf loc+  locOf (ParamType _ usage) = locOf usage   locOf (Constraint _ usage) = locOf usage   locOf (Overloaded _ usage) = locOf usage   locOf (HasFields _ usage) = locOf usage   locOf (Equality usage) = locOf usage   locOf (HasConstrs _ usage) = locOf usage+  locOf (ParamSize loc) = locOf loc+  locOf (Size _ usage) = locOf usage+  locOf (UnknowableSize loc _) = locOf loc  -- | Mapping from fresh type variables, instantiated from the type -- schemes of polymorphic functions, to (possibly) specific types as@@ -83,13 +148,104 @@ -- a partial constraint on their type. type Constraints = M.Map VName (Level, Constraint) -lookupSubst :: VName -> Constraints -> Maybe (Subst (TypeBase () ()))-lookupSubst v constraints = case M.lookup v constraints of-                              Just (_, Constraint t _) -> Just $ Subst t-                              Just (_, Overloaded{}) -> Just PrimSubst+lookupSubst :: VName -> Constraints -> Maybe (Subst StructType)+lookupSubst v constraints = case snd <$> M.lookup v constraints of+                              Just (Constraint t _) -> Just $ Subst t+                              Just Overloaded{} -> Just PrimSubst+                              Just (Size (Just d) _) ->+                                Just $ SizeSubst $ applySubst (`lookupSubst` constraints) d                               _ -> Nothing -class (MonadBreadCrumbs m, MonadError TypeError m) => MonadUnify m where+-- | The source of a rigid size.+data RigidSource+  = RigidArg (Maybe (QualName VName)) String+    -- ^ A function argument that is not a constant or variable name.+  | RigidRet (Maybe (QualName VName))+    -- ^ An existential return size.+  | RigidLoop+  | RigidSlice (Maybe (DimDecl VName)) String+    -- ^ Produced by a complicated slice expression.+  | RigidRange+    -- ^ Produced by a complicated range expression.+  | RigidBound String+    -- ^ Produced by a range expression with this bound.+  | RigidCond StructType StructType+    -- ^ Mismatch in branches.+  | RigidUnify+    -- ^ Invented during unification.+  | RigidOutOfScope SrcLoc VName+  deriving (Eq, Ord, Show)++-- | The ridigity of a size variable.  All rigid sizes are tagged with+-- information about how they were generated.+data Rigidity = Rigid RigidSource | Nonrigid+              deriving (Eq, Ord, Show)++prettySource :: SrcLoc -> SrcLoc -> RigidSource -> Doc++prettySource ctx loc (RigidRet Nothing) =+  "is unknown size returned by function at" <+>+  text (locStrRel ctx loc) <> "."++prettySource ctx loc (RigidRet (Just fname)) =+  "is unknown size returned by" <+> pquote (ppr fname) <+>+  "at" <+> text (locStrRel ctx loc) <> "."++prettySource ctx loc (RigidArg fname arg) =+  "is value of argument" </>+  indent 2 (shorten arg) </>+  "passed to" <+> fname' <+> "at" <+> text (locStrRel ctx loc) <> "."+  where fname' = maybe "function" (pquote . ppr) fname++prettySource ctx loc (RigidSlice d slice) =+  "is size produced by slice" </>+  indent 2 (shorten slice) </>+  d_desc <> "at" <+> text (locStrRel ctx loc) <> "."+  where d_desc = case d of+                   Just d' -> "of dimension of size " <> pquote (ppr d') <> " "+                   Nothing -> mempty++prettySource ctx loc RigidLoop =+  "is unknown size of value returned at" <+> text (locStrRel ctx loc) <> "."++prettySource ctx loc RigidRange =+  "is unknown length of range at" <+> text (locStrRel ctx loc) <> "."++prettySource ctx loc (RigidBound bound) =+  "generated from expression" </>+  indent 2 (shorten bound) </>+  "used in range at " <> text (locStrRel ctx loc) <> "."++prettySource ctx loc (RigidOutOfScope boundloc v) =+  "is an unknown size arising from " <> pquote (pprName v) <>+  " going out of scope at " <> text (locStrRel ctx loc) <> "." </>+  "Originally bound at " <> text (locStrRel ctx boundloc) <> "."++prettySource _ _ RigidUnify =+  "is an artificial size invented during unification of functions with anonymous sizes"++prettySource ctx loc (RigidCond t1 t2) =+  "is unknown due to conditional expression at " <>+  text (locStrRel ctx loc) <> "." </>+  "One branch returns array of type: " <> align (ppr t1) </>+  "The other an array of type:       " <> align (ppr t2)++dimNotes :: (Located a, MonadUnify m) => a -> DimDecl VName -> m Notes+dimNotes ctx (NamedDim d) = do+  c <- M.lookup (qualLeaf d) <$> getConstraints+  case c of+    Just (_, UnknowableSize loc rsrc) ->+      return $ aNote $ pretty $+      pquote (ppr d) <+> prettySource (srclocOf ctx) loc rsrc+    _ -> return mempty+dimNotes _ _ = return mempty++typeNotes :: (Located a, MonadUnify m) => a -> StructType -> m Notes+typeNotes ctx =+  fmap mconcat . mapM (dimNotes ctx . NamedDim . qualName) .+  S.toList . typeDimNames++class Monad m => MonadUnify m where   getConstraints :: m Constraints   putConstraints :: Constraints -> m ()   modifyConstraints :: (Constraints -> Constraints) -> m ()@@ -98,17 +254,56 @@     putConstraints $ f x    newTypeVar :: Monoid als => SrcLoc -> String -> m (TypeBase dim als)+  newDimVar :: SrcLoc -> Rigidity -> String -> m VName    curLevel :: m Level -normaliseType :: (Substitutable a, MonadUnify m) => a -> m a-normaliseType t = do constraints <- getConstraints+  matchError :: Located loc => loc -> Notes -> BreadCrumbs+             -> StructType -> StructType -> m a++  unifyError :: Located loc => loc -> Notes -> BreadCrumbs+             -> Doc -> m a++normTypeFully :: (Substitutable a, MonadUnify m) => a -> m a+normTypeFully t = do constraints <- getConstraints                      return $ applySubst (`lookupSubst` constraints) t +normType :: MonadUnify m => StructType -> m StructType+normType t@(Scalar (TypeVar _ _ (TypeName [] v) [])) = do+  constraints <- getConstraints+  case snd <$> M.lookup v constraints of+    Just (Constraint t' _) -> normType t'+    _ -> return t+normType t = return t++normPatternType :: MonadUnify m => PatternType -> m PatternType+normPatternType t@(Scalar (TypeVar als u (TypeName [] v) [])) = do+  constraints <- getConstraints+  case snd <$> M.lookup v constraints of+    Just (Constraint t' _) ->+      normPatternType $ t' `setUniqueness` u `setAliases` als+    _ -> return t+normPatternType t = return t+ rigidConstraint :: Constraint -> Bool rigidConstraint ParamType{} = True+rigidConstraint ParamSize{} = True+rigidConstraint UnknowableSize{} = True rigidConstraint _ = False +instantiateEmptyArrayDims :: MonadUnify m =>+                             SrcLoc -> String -> Rigidity+                          -> TypeBase (DimDecl VName) als+                          -> m (TypeBase (DimDecl VName) als, [VName])+instantiateEmptyArrayDims tloc desc r = runWriterT . traverseDims onDim+  where onDim PosImmediate AnyDim = inst+        onDim PosParam AnyDim = inst+        onDim _ d = return d+        inst = do+          dim <- lift $ newDimVar tloc r desc+          tell [dim]+          return $ NamedDim $ qualName dim+ -- | Is the given type variable the name of an abstract type or type -- parameter, which we cannot substitute? isRigid :: VName -> Constraints -> Bool@@ -122,149 +317,236 @@   guard $ not $ rigidConstraint c   return lvl -unifySharedConstructors :: MonadUnify m =>-                           Usage-                        -> M.Map Name [TypeBase () ()]-                        -> M.Map Name [TypeBase () ()]-                        -> m ()-unifySharedConstructors usage cs1 cs2 =-  forM_ (M.toList $ M.intersectionWith (,) cs1 cs2) $ \(c, (f1, f2)) ->-  unifyConstructor c f1 f2-  where unifyConstructor c f1 f2-          | length f1 == length f2 =-              zipWithM_ (unify usage) f1 f2-          | otherwise = typeError usage $ "Cannot unify constructor " ++-                        quote (prettyName c) ++ "."--indent :: String -> String-indent = intercalate "\n" . map ("  "++) . lines+type UnifyDims m =+  BreadCrumbs -> [VName] -> (VName -> Maybe Int) -> DimDecl VName -> DimDecl VName -> m () --- | Unifies two types.-unify :: MonadUnify m => Usage -> TypeBase () () -> TypeBase () () -> m ()-unify usage orig_t1 orig_t2 = do-  orig_t1' <- normaliseType orig_t1-  orig_t2' <- normaliseType orig_t2-  breadCrumb (MatchingTypes orig_t1' orig_t2') $ subunify orig_t1' orig_t2'+unifyWith :: MonadUnify m =>+             UnifyDims m -> Usage -> BreadCrumbs+          -> StructType -> StructType -> m ()+unifyWith onDims usage = subunify False mempty   where-    subunify t1 t2 = do+    swap True x y = (y, x)+    swap False x y = (x, y)++    subunify ord bound bcs t1 t2 = do       constraints <- getConstraints +      t1' <- normType t1+      t2' <- normType t2+       let nonrigid v = isNonRigid v constraints-          t1' = applySubst (`lookupSubst` constraints) t1-          t2' = applySubst (`lookupSubst` constraints) t2 -          failure-            -- This case is to avoid repeating the types that are also-            -- shown in the breadcrumb.-            | t1 == orig_t1, t2 == orig_t2 =-                typeError (srclocOf usage) "Types do not match."-            | otherwise =-                typeError (srclocOf usage) $ "Couldn't match expected type\n" ++-                indent (pretty t1') ++ "\nwith actual type\n" ++ indent (pretty t2')+          failure = matchError (srclocOf usage) mempty bcs t1' t2' -      case (t1', t2') of-        _ | t1' == t2' -> return ()+          -- Remove any of the intermediate dimensions we added just+          -- for unification purposes.+          link v lvl = linkVarToType onDims usage bcs v lvl . applySubst unbind+            where unbind d | d `elem` bound = Just $ SizeSubst AnyDim+                           | otherwise      = Nothing +          unifyTypeArg bcs' (TypeArgDim d1 _) (TypeArgDim d2 _) =+            onDims' bcs' (swap ord d1 d2)+          unifyTypeArg bcs' (TypeArgType t _) (TypeArgType arg_t _) =+            subunify ord bound bcs' t arg_t+          unifyTypeArg bcs' _ _ = unifyError usage mempty bcs'+            "Cannot unify a type argument with a dimension argument (or vice versa)."++          onDims' bcs' (d1, d2) =+            onDims bcs' bound nonrigid+            (applySubst (`lookupSubst` constraints) d1)+            (applySubst (`lookupSubst` constraints) d2)++      case (t1', t2') of         (Scalar (Record fs),          Scalar (Record arg_fs))           | M.keys fs == M.keys arg_fs ->-              forM_ (M.toList $ M.intersectionWith (,) fs arg_fs) $ \(k, (k_t1, k_t2)) ->-              breadCrumb (MatchingFields k) $ subunify k_t1 k_t2+              forM_ (M.toList $ M.intersectionWith (,) fs arg_fs) $ \(k, (k_t1, k_t2)) -> do+              let bcs' = breadCrumb (MatchingFields [k]) bcs+              subunify ord bound bcs' k_t1 k_t2+          | otherwise -> do+              let missing = filter (`notElem` M.keys arg_fs) (M.keys fs) +++                            filter (`notElem` M.keys fs) (M.keys arg_fs)+              unifyError usage mempty bcs $+                "Unshared fields:" <+> commasep (map ppr missing) <> "."          (Scalar (TypeVar _ _ (TypeName _ tn) targs),          Scalar (TypeVar _ _ (TypeName _ arg_tn) arg_targs))-          | tn == arg_tn, length targs == length arg_targs ->-              zipWithM_ unifyTypeArg targs arg_targs+          | tn == arg_tn, length targs == length arg_targs -> do+            let bcs' = breadCrumb (Matching "When matching type arguments.") bcs+            zipWithM_ (unifyTypeArg bcs') targs arg_targs          (Scalar (TypeVar _ _ (TypeName [] v1) []),          Scalar (TypeVar _ _ (TypeName [] v2) [])) ->           case (nonrigid v1, nonrigid v2) of             (Nothing, Nothing) -> failure-            (Just lvl1, Nothing) -> linkVarToType usage v1 lvl1 t2'-            (Nothing, Just lvl2) -> linkVarToType usage v2 lvl2 t1'+            (Just lvl1, Nothing) -> link v1 lvl1 t2'+            (Nothing, Just lvl2) -> link v2 lvl2 t1'             (Just lvl1, Just lvl2)-              | lvl1 <= lvl2 -> linkVarToType usage v1 lvl1 t2'-              | otherwise    -> linkVarToType usage v2 lvl2 t1'+              | lvl1 <= lvl2 -> link v1 lvl1 t2'+              | otherwise    -> link v2 lvl2 t1'          (Scalar (TypeVar _ _ (TypeName [] v1) []), _)-          | Just lvl <-  nonrigid v1 ->-              linkVarToType usage v1 lvl t2'+          | Just lvl <- nonrigid v1 ->+              link v1 lvl t2'         (_, Scalar (TypeVar _ _ (TypeName [] v2) []))           | Just lvl <- nonrigid v2 ->-              linkVarToType usage v2 lvl t1'+              link v2 lvl t1' -        (Scalar (Arrow _ _ a1 b1),-         Scalar (Arrow _ _ a2 b2)) -> do-          subunify a1 a2-          subunify b1 b2+        (Scalar (Arrow _ p1 a1 b1),+         Scalar (Arrow _ p2 a2 b2)) -> do+          let (r1, r2) = swap ord (Rigid RigidUnify) Nonrigid+          (a1', a1_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r1 a1+          (a2', a2_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r2 a2+          let bound' = bound <> mapMaybe pname [p1, p2] <> a1_dims <> a2_dims+          subunify (not ord) bound+            (breadCrumb (Matching "When matching parameter types.") bcs)+            a1' a2'+          subunify ord bound'+            (breadCrumb (Matching "When matching return types.") bcs)+            b1' b2'+          where (b1', b2') =+                  -- Replace one parameter name with the other in the+                  -- return type, in case of dependent types.  I.e.,+                  -- we want type '(n: i32) -> [n]i32' to unify with+                  -- type '(x: i32) -> [x]i32'.+                  case (p1, p2) of+                    (Named p1', Named p2') ->+                      let f v | v == p2' = Just $ SizeSubst $ NamedDim $ qualName p1'+                              | otherwise = Nothing+                      in (b1, applySubst f b2) +                    (_, _) ->+                      (b1, b2)++                pname (Named x) = Just x+                pname Unnamed = Nothing+         (Array{}, Array{})-          | Just t1'' <- peelArray 1 t1',-            Just t2'' <- peelArray 1 t2' ->-              subunify t1'' t2''+          | ShapeDecl (t1_d : _) <- arrayShape t1',+            ShapeDecl (t2_d : _) <- arrayShape t2',+            Just t1'' <- peelArray 1 t1',+            Just t2'' <- peelArray 1 t2' -> do+              onDims' bcs (swap ord t1_d t2_d)+              subunify ord bound bcs t1'' t2''          (Scalar (Sum cs),          Scalar (Sum arg_cs))           | M.keys cs == M.keys arg_cs ->-              unifySharedConstructors usage cs arg_cs-        (_, _) -> failure+              unifySharedConstructors onDims usage bcs cs arg_cs+          | otherwise -> do+              let missing = filter (`notElem` M.keys arg_cs) (M.keys cs) +++                            filter (`notElem` M.keys cs) (M.keys arg_cs)+              unifyError usage mempty bcs $+                "Unshared constructors:" <+> commasep (map (("#"<>) . ppr) missing) <> "." -      where unifyTypeArg TypeArgDim{} TypeArgDim{} = return ()-            unifyTypeArg (TypeArgType t _) (TypeArgType arg_t _) =-              subunify t arg_t-            unifyTypeArg _ _ = typeError usage-              "Cannot unify a type argument with a dimension argument (or vice versa)."+        _ | t1' == t2' -> return ()+          | otherwise -> failure -applySubstInConstraint :: VName -> Subst (TypeBase () ()) -> Constraint -> Constraint-applySubstInConstraint vn subst (Constraint t loc) =-  Constraint (applySubst (flip M.lookup $ M.singleton vn subst) t) loc-applySubstInConstraint vn subst (HasFields fs loc) =-  HasFields (M.map (applySubst (flip M.lookup $ M.singleton vn subst)) fs) loc-applySubstInConstraint _ _ (NoConstraint l loc) = NoConstraint l loc-applySubstInConstraint _ _ (Overloaded ts usage) = Overloaded ts usage-applySubstInConstraint _ _ (Equality loc) = Equality loc-applySubstInConstraint _ _ (ParamType l loc) = ParamType l loc-applySubstInConstraint vn subst (HasConstrs cs loc) =-  HasConstrs (M.map (map (applySubst (flip M.lookup $ M.singleton vn subst))) cs) loc+unifyDims :: MonadUnify m => Usage -> UnifyDims m+unifyDims _ _ _ _ d1 d2+  | d1 == d2 = return ()+unifyDims usage bcs _ nonrigid (NamedDim (QualName _ d1)) d2+  | Just lvl1 <- nonrigid d1 =+      linkVarToDim usage bcs d1 lvl1 d2+unifyDims usage bcs _ nonrigid d1 (NamedDim (QualName _ d2))+  | Just lvl2 <- nonrigid d2 =+      linkVarToDim usage bcs d2 lvl2 d1+unifyDims usage bcs _ _ d1 d2 = do+  notes <- (<>) <$> dimNotes usage d1 <*> dimNotes usage d2+  unifyError usage notes bcs $+    "Dimensions" <+> pquote (ppr d1) <+>+    "and" <+> pquote (ppr d2) <+> "do not match." -occursCheck :: MonadUnify m => Usage -> VName -> TypeBase () () -> m ()-occursCheck usage vn tp =+-- | Unifies two types.+unify :: MonadUnify m => Usage -> StructType -> StructType -> m ()+unify usage = unifyWith (unifyDims usage) usage noBreadCrumbs++-- | @expect super sub@ checks that @sub@ is a subtype of @super@.+expect :: MonadUnify m => Usage -> StructType -> StructType -> m ()+expect usage = unifyWith onDims usage noBreadCrumbs+  where onDims _ _ _ AnyDim _ = return ()+        onDims _ _ _ d1 d2+          | d1 == d2 = return ()+        onDims bcs bound nonrigid (NamedDim (QualName _ d1)) d2+          | Just lvl1 <- nonrigid d1, d2 /= AnyDim, not $ boundParam bound d2 =+              linkVarToDim usage bcs d1 lvl1 d2+        onDims bcs bound nonrigid d1 (NamedDim (QualName _ d2))+          | Just lvl2 <- nonrigid d2, not $ boundParam bound d1 =+              linkVarToDim usage bcs d2 lvl2 d1+        onDims bcs _ _ d1 d2 = do+          notes <- (<>) <$> dimNotes usage d1 <*> dimNotes usage d2+          unifyError usage notes bcs $ "Dimensions" <+> pquote (ppr d1) <+>+            "and" <+> pquote (ppr d2) <+> "do not match."++        boundParam bound (NamedDim (QualName _ d)) = d `elem` bound+        boundParam _ _ = False++hasEmptyDims :: StructType -> Bool+hasEmptyDims = biany empty (const False)+  where empty AnyDim = True+        empty _ = False++occursCheck :: MonadUnify m =>+               Usage -> BreadCrumbs+            -> VName -> StructType -> m ()+occursCheck usage bcs vn tp =   when (vn `S.member` typeVars tp) $-  typeError usage $ "Occurs check: cannot instantiate " ++-  prettyName vn ++ " with " ++ pretty tp+  unifyError usage mempty bcs $ "Occurs check: cannot instantiate" <+>+  pprName vn <+> "with" <+> ppr tp <> "." -scopeCheck :: MonadUnify m => Usage -> VName -> Level -> TypeBase () () -> m ()-scopeCheck usage vn max_lvl tp = do+scopeCheck :: MonadUnify m =>+              Usage -> BreadCrumbs+           -> VName -> Level -> StructType -> m ()+scopeCheck usage bcs vn max_lvl tp = do   constraints <- getConstraints-  mapM_ (check constraints) $ typeVars tp-  where check constraints v+  checkType constraints tp+  where checkType constraints t =+          mapM_ (check constraints) $ typeVars t <> typeDimNames t++        check constraints v           | Just (lvl, c) <- M.lookup v constraints,             lvl > max_lvl =               if rigidConstraint c               then scopeViolation v               else modifyConstraints $ M.insert v (max_lvl, c)+           | otherwise =               return () -        scopeViolation v =-          typeError usage $ "Cannot unify type variable " ++ quote (prettyName v) ++-          " with " ++ quote (prettyName vn) ++ " (scope violation).\n" ++-          "This is because " ++ quote (prettyName vn) ++ " is rigidly bound in a deeper scope."+        scopeViolation v = do+          notes <- typeNotes usage tp+          unifyError usage notes bcs $ "Cannot unify type" </>+            indent 2 (ppr tp) </>+            "with" <+> pquote (pprName vn) <+> "(scope violation)." </>+            "This is because" <+> pquote (pprName v) <+>+            "is rigidly bound in a deeper scope." -linkVarToType :: MonadUnify m => Usage -> VName -> Level -> TypeBase () () -> m ()-linkVarToType usage vn lvl tp = do-  occursCheck usage vn tp-  scopeCheck usage vn lvl tp+linkVarToType :: MonadUnify m =>+                 UnifyDims m -> Usage -> BreadCrumbs+              -> VName -> Level -> StructType -> m ()+linkVarToType onDims usage bcs vn lvl tp = do+  occursCheck usage bcs vn tp+  scopeCheck usage bcs vn lvl tp    constraints <- getConstraints+  let tp' = removeUniqueness tp   modifyConstraints $ M.insert vn (lvl, Constraint tp' usage)-  modifyConstraints $ M.map $ fmap $ applySubstInConstraint vn $ Subst tp'-   case snd <$> M.lookup vn constraints of -    Just (NoConstraint Unlifted unlift_usage) ->-      zeroOrderType usage (show unlift_usage) tp'+    Just (NoConstraint Unlifted unlift_usage) -> do+      let bcs' = breadCrumb+                 (Matching $ "When verifying that" <+> pquote (pprName vn) <+>+                  textwrap "is not instantiated with a function type, due to" <+>+                  ppr unlift_usage)+                 bcs+      zeroOrderTypeWith usage bcs' tp' +      when (hasEmptyDims tp') $+        unifyError usage mempty bcs $ "Type variable" <+> pprName vn <+>+        "cannot be instantiated with type containing anonymous sizes:" </>+        indent 2 (ppr tp) </>+        textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically.  This can also be due to the return size beind a value parameter.  Add type annotation to clarify."+     Just (Equality _) ->       equalityType usage tp' @@ -275,11 +557,11 @@               | not $ isRigid v constraints ->                   linkVarToTypes usage v ts             _ ->-              typeError usage $ "Cannot unify " ++ quote (prettyName vn) ++-              "' with type\n" ++ indent (pretty tp) ++ "\nas " ++-              quote (prettyName vn) ++ " must be one of " ++-              intercalate ", " (map pretty ts) ++-              " due to " ++ show old_usage ++ ")."+              unifyError usage mempty bcs $ "Cannot instantiate" <+> pquote (pprName vn) <+>+              "with type" </> indent 2 (ppr tp) </> "as" <+>+              pquote (pprName vn) <+> "must be one of" <+>+              commasep (map ppr ts) <+/>+              "due to" <+/> ppr old_usage <> "."      Just (HasFields required_fields old_usage) ->       case tp of@@ -292,35 +574,59 @@               modifyConstraints $ M.insert v               (lvl, HasFields required_fields old_usage)         _ ->-          typeError usage $-          "Cannot unify " ++ quote (prettyName vn) ++ " with type\n" ++-          indent (pretty tp) ++ "\nas " ++ quote (prettyName vn) ++-          " must be a record with fields\n" ++-          pretty (Record required_fields) ++-          "\ndue to " ++ show old_usage ++ "."+          unifyError usage mempty bcs $+          "Cannot instantiate" <+> pquote (pprName vn) <+> "with type" </>+          indent 2 (ppr tp) </>+          "as" <+> pquote (pprName vn) <+> "must be a record with fields" </>+          indent 2 (ppr (Record required_fields)) </>+          "due to" <+> ppr old_usage <> "."      Just (HasConstrs required_cs old_usage) ->       case tp of         Scalar (Sum ts)           | all (`M.member` ts) $ M.keys required_cs ->-              unifySharedConstructors usage required_cs ts+              unifySharedConstructors onDims usage bcs required_cs ts         Scalar (TypeVar _ _ (TypeName [] v) [])           | not $ isRigid v constraints -> do               case M.lookup v constraints of                 Just (_, HasConstrs v_cs _) ->-                  unifySharedConstructors usage required_cs v_cs+                  unifySharedConstructors onDims usage bcs required_cs v_cs                 _ -> return ()               modifyConstraints $ M.insertWith combineConstrs v                 (lvl, HasConstrs required_cs old_usage)               where combineConstrs (_, HasConstrs cs1 usage1) (_, HasConstrs cs2 _) =                       (lvl, HasConstrs (M.union cs1 cs2) usage1)                     combineConstrs hasCs _ = hasCs-        _ -> typeError usage "Cannot unify a sum type with a non-sum type"+        _ -> noSumType      _ -> return () -  where tp' = removeUniqueness tp+  where noSumType = unifyError usage mempty bcs+                    "Cannot unify a sum type with a non-sum type" +linkVarToDim :: MonadUnify m =>+                Usage -> BreadCrumbs+             -> VName -> Level -> DimDecl VName -> m ()+linkVarToDim usage bcs vn lvl dim = do+  constraints <- getConstraints++  case dim of+    NamedDim dim'+      | Just (dim_lvl, c) <- qualLeaf dim' `M.lookup` constraints,+        dim_lvl > lvl ->+          case c of+            ParamSize{} -> do+              notes <- dimNotes usage dim+              unifyError usage notes bcs $+                "Cannot unify size variable" <+> pquote (ppr dim') <+>+                "with" <+> pquote (pprName vn) <+> "(scope violation)." </>+                "This is because" <+> pquote (ppr dim') <+>+                "is rigidly bound in a deeper scope."+            _ -> modifyConstraints $ M.insert (qualLeaf dim') (lvl, c)+    _ -> return ()++  modifyConstraints $ M.insert vn (lvl, Size (Just dim) usage)+ removeUniqueness :: TypeBase dim as -> TypeBase dim as removeUniqueness (Scalar (Record ets)) =   Scalar $ Record $ fmap removeUniqueness ets@@ -330,23 +636,24 @@   Scalar $ Sum $ (fmap . fmap) removeUniqueness cs removeUniqueness t = t `setUniqueness` Nonunique -mustBeOneOf :: MonadUnify m => [PrimType] -> Usage -> TypeBase () () -> m ()-mustBeOneOf [req_t] loc t = unify loc (Scalar (Prim req_t)) t-mustBeOneOf ts loc t = do+mustBeOneOf :: MonadUnify m => [PrimType] -> Usage -> StructType -> m ()+mustBeOneOf [req_t] usage t = unify usage (Scalar (Prim req_t)) t+mustBeOneOf ts usage t = do+  t' <- normType t   constraints <- getConstraints-  let t' = applySubst (`lookupSubst` constraints) t-      isRigid' v = isRigid v constraints+  let isRigid' v = isRigid v constraints    case t' of     Scalar (TypeVar _ _ (TypeName [] v) [])-      | not $ isRigid' v -> linkVarToTypes loc v ts+      | not $ isRigid' v -> linkVarToTypes usage v ts      Scalar (Prim pt) | pt `elem` ts -> return ()      _ -> failure -  where failure = typeError loc $ "Cannot unify type \"" ++ pretty t ++-                  "\" with any of " ++ intercalate "," (map pretty ts) ++ "."+  where failure = unifyError usage mempty noBreadCrumbs $+                  text "Cannot unify type" <+> pquote (ppr t) <+>+                  "with any of " <> commasep (map ppr ts) <> "."  linkVarToTypes :: MonadUnify m => Usage -> VName -> [PrimType] -> m () linkVarToTypes usage vn ts = do@@ -354,31 +661,34 @@   case vn_constraint of     Just (lvl, Overloaded vn_ts vn_usage) ->       case ts `intersect` vn_ts of-        [] -> typeError usage $ "Type constrained to one of " ++-              intercalate "," (map pretty ts) ++ " but also one of " ++-              intercalate "," (map pretty vn_ts) ++ " due to " ++ show vn_usage ++ "."+        [] -> unifyError usage mempty noBreadCrumbs $+              "Type constrained to one of" <+>+              commasep (map ppr ts) <+> "but also one of" <+>+              commasep (map ppr vn_ts) <+> "due to" <+> ppr vn_usage <> "."         ts' -> modifyConstraints $ M.insert vn (lvl, Overloaded ts' usage)      Just (_, HasConstrs _ vn_usage) ->-      typeError usage $ "Type constrained to one of " ++-      intercalate "," (map pretty ts) ++ ", but also inferred to be sum type due to " ++-      show vn_usage ++ "."+      unifyError usage mempty noBreadCrumbs $+      "Type constrained to one of" <+> commasep (map ppr ts) <>+      ", but also inferred to be sum type due to" <+> ppr vn_usage <> "."      Just (_, HasFields _ vn_usage) ->-      typeError usage $ "Type constrained to one of " ++-      intercalate "," (map pretty ts) ++ ", but also inferred to be record due to " ++-      show vn_usage ++ "."+      unifyError usage mempty noBreadCrumbs $+      "Type constrained to one of" <+> commasep (map ppr ts) <>+      ", but also inferred to be record due to" <+> ppr vn_usage <> "."      Just (lvl, _) -> modifyConstraints $ M.insert vn (lvl, Overloaded ts usage) -    Nothing -> typeError usage $ "Cannot constrain type to one of " ++ intercalate "," (map pretty ts)+    Nothing ->+      unifyError usage mempty noBreadCrumbs $+      "Cannot constrain type to one of" <+> commasep (map ppr ts)  equalityType :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>                 Usage -> TypeBase dim as -> m () equalityType usage t = do   unless (orderZero t) $-    typeError usage $-    "Type \"" ++ pretty t ++ "\" does not support equality (is higher-order)."+    unifyError usage mempty noBreadCrumbs $+    "Type " <+> pquote (ppr t) <+> "does not support equality (is higher-order)."   mapM_ mustBeEquality $ typeVars t   where mustBeEquality vn = do           constraints <- getConstraints@@ -387,9 +697,9 @@               mustBeEquality vn'             Just (_, Constraint vn_t cusage)               | not $ orderZero vn_t ->-                  typeError usage $-                  unlines ["Type \"" ++ pretty t ++ "\" does not support equality.",-                           "Constrained to be higher-order due to " ++ show cusage ++ "."]+                  unifyError usage mempty noBreadCrumbs $+                  "Type" <+> pquote (ppr t) <+> "does not support equality." </>+                  "Constrained to be higher-order due to" <+> ppr cusage <+> "."               | otherwise -> return ()             Just (lvl, NoConstraint _ _) ->               modifyConstraints $ M.insert vn (lvl, Equality usage)@@ -400,92 +710,160 @@             Just (_, HasConstrs cs _) ->               mapM_ (equalityType usage) $ concat $ M.elems cs             _ ->-              typeError usage $ "Type " ++ pretty (prettyName vn) ++-              " does not support equality."+              unifyError usage mempty noBreadCrumbs $+              "Type" <+> pprName vn <+> "does not support equality." -zeroOrderType :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>-                 Usage -> String -> TypeBase dim as -> m ()-zeroOrderType usage desc t = do+zeroOrderTypeWith :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>+                     Usage -> BreadCrumbs -> TypeBase dim as -> m ()+zeroOrderTypeWith usage bcs t = do   unless (orderZero t) $-    typeError usage $ "Type " ++ desc ++-    " must not be functional, but is " ++ quote (pretty t) ++ "."+    unifyError usage mempty bcs $+    "Type" </> indent 2 (ppr t) </> "found to be functional."   mapM_ mustBeZeroOrder . S.toList . typeVars $ t   where mustBeZeroOrder vn = do           constraints <- getConstraints           case M.lookup vn constraints of-            Just (_, Constraint vn_t old_usage)-              | not $ orderZero t ->-                typeError usage $ "Type " ++ desc ++-                " must be non-function, but inferred to be " ++-                quote (pretty vn_t) ++ " due to " ++ show old_usage ++ "."             Just (lvl, NoConstraint _ _) ->               modifyConstraints $ M.insert vn (lvl, NoConstraint Unlifted usage)             Just (_, ParamType Lifted ploc) ->-              typeError usage $ "Type " ++ desc ++-              " must be non-function, but type parameter " ++ quote (prettyName vn) ++ " at " ++-              locStr ploc ++ " may be a function."+              unifyError usage mempty bcs $ "Type parameter" <+>+              pquote (pprName vn) <+> "at" <+>+              text (locStr ploc) <+> "may be a function."             _ -> return () +zeroOrderType :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>+                 Usage -> String -> TypeBase dim as -> m ()+zeroOrderType usage desc =+  zeroOrderTypeWith usage $ breadCrumb bc noBreadCrumbs+  where bc = Matching $ "When checking" <+> textwrap desc++unifySharedConstructors :: MonadUnify m =>+                           UnifyDims m -> Usage -> BreadCrumbs+                        -> M.Map Name [StructType]+                        -> M.Map Name [StructType]+                        -> m ()+unifySharedConstructors onDims usage bcs cs1 cs2 =+  forM_ (M.toList $ M.intersectionWith (,) cs1 cs2) $ \(c, (f1, f2)) ->+  unifyConstructor c f1 f2+  where unifyConstructor c f1 f2+          | length f1 == length f2 = do+              let bcs' = breadCrumb (MatchingConstructor c) bcs+              zipWithM_ (unifyWith onDims usage bcs') f1 f2+          | otherwise =+              unifyError usage mempty bcs $+              "Cannot unify constructor" <+> pquote (pprName c) <> "."+ -- | In @mustHaveConstr usage c t fs@, the type @t@ must have a -- constructor named @c@ that takes arguments of types @ts@. mustHaveConstr :: MonadUnify m =>-                  Usage -> Name -> TypeBase dim as -> [TypeBase () ()] -> m ()+                  Usage -> Name -> StructType -> [StructType] -> m () mustHaveConstr usage c t fs = do-  let struct_f = toStructural <$> fs   constraints <- getConstraints   case t of     Scalar (TypeVar _ _ (TypeName _ tn) [])       | Just (lvl, NoConstraint{}) <- M.lookup tn constraints -> do-          mapM_ (scopeCheck usage tn lvl) struct_f-          modifyConstraints $ M.insert tn (lvl, HasConstrs (M.singleton c struct_f) usage)+          mapM_ (scopeCheck usage noBreadCrumbs tn lvl) fs+          modifyConstraints $ M.insert tn (lvl, HasConstrs (M.singleton c fs) usage)       | Just (lvl, HasConstrs cs _) <- M.lookup tn constraints ->-          case M.lookup c cs of-            Nothing  -> modifyConstraints $ M.insert tn (lvl, HasConstrs (M.insert c fs cs) usage)-            Just fs'-              | length fs == length fs' -> zipWithM_ (unify usage) fs fs'-              | otherwise -> typeError usage $ "Different arity for constructor "-                             ++ quote (pretty c) ++ "."+        case M.lookup c cs of+          Nothing  -> modifyConstraints $ M.insert tn (lvl, HasConstrs (M.insert c fs cs) usage)+          Just fs'+            | length fs == length fs' -> zipWithM_ (unify usage) fs fs'+            | otherwise ->+                unifyError usage mempty noBreadCrumbs $+                "Different arity for constructor" <+> pquote (ppr c) <> "."      Scalar (Sum cs) ->       case M.lookup c cs of-        Nothing -> typeError usage $ "Constuctor " ++ quote (pretty c) ++ " not present in type."+        Nothing ->+          unifyError usage mempty noBreadCrumbs $+          "Constuctor" <+> pquote (ppr c) <+> "not present in type."         Just fs'-            | length fs == length fs' -> zipWithM_ (unify usage) fs (toStructural <$> fs')-            | otherwise -> typeError usage $ "Different arity for constructor " ++-                           quote (pretty c) ++ "."+            | length fs == length fs' -> zipWithM_ (unify usage) fs fs'+            | otherwise ->+                unifyError usage mempty noBreadCrumbs $+                "Different arity for constructor" <+> pquote (ppr c) <+> "." -    _ -> do unify usage (toStructural t) $ Scalar $ Sum $ M.singleton c fs+    _ -> do unify usage t $ Scalar $ Sum $ M.singleton c fs             return () -mustHaveField :: (MonadUnify m, Monoid as) =>-                 Usage -> Name -> TypeBase dim as -> m (TypeBase dim as)-mustHaveField usage l t = do+mustHaveFieldWith :: MonadUnify m =>+                     UnifyDims m -> Usage -> BreadCrumbs+                  -> Name -> PatternType -> m PatternType+mustHaveFieldWith onDims usage bcs l t = do   constraints <- getConstraints   l_type <- newTypeVar (srclocOf usage) "t"-  let l_type' = toStructural l_type+  let l_type' = toStruct l_type   case t of     Scalar (TypeVar _ _ (TypeName _ tn) [])       | Just (lvl, NoConstraint{}) <- M.lookup tn constraints -> do-          scopeCheck usage tn lvl l_type'+          scopeCheck usage bcs tn lvl l_type'           modifyConstraints $ M.insert tn (lvl, HasFields (M.singleton l l_type') usage)           return l_type       | Just (lvl, HasFields fields _) <- M.lookup tn constraints -> do           case M.lookup l fields of-            Just t' -> unify usage l_type' t'+            Just t' -> unifyWith onDims usage bcs l_type' t'             Nothing -> modifyConstraints $ M.insert tn                        (lvl, HasFields (M.insert l l_type' fields) usage)           return l_type     Scalar (Record fields)       | Just t' <- M.lookup l fields -> do-          unify usage l_type' (toStructural t')+          unify usage l_type' $ toStruct t'           return t'       | otherwise ->-          typeError usage $-          "Attempt to access field " ++ quote (pretty l) ++ " of value of type " ++-          quote (pretty (toStructural t)) ++ "."-    _ -> do unify usage (toStructural t) $ Scalar $ Record $ M.singleton l l_type'+          unifyError usage mempty bcs $+            "Attempt to access field" <+> pquote (ppr l) <+> " of value of type" <+>+            ppr (toStructural t) <> "."+    _ -> do unify usage (toStruct t) $ Scalar $ Record $ M.singleton l l_type'             return l_type +mustHaveField :: MonadUnify m =>+                 Usage -> Name -> PatternType -> m PatternType+mustHaveField usage = mustHaveFieldWith (unifyDims usage) usage noBreadCrumbs++-- | Replace dimension mismatches with AnyDim.+anyDimOnMismatch :: Monoid as =>+                    TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as+                 -> (TypeBase (DimDecl VName) as, [(DimDecl VName, DimDecl VName)])+anyDimOnMismatch t1 t2 = runWriter $ matchDims onDims t1 t2+  where onDims d1 d2+          | d1 == d2 = return d1+          | otherwise = do tell [(d1, d2)]+                           return AnyDim++newDimOnMismatch :: (Monoid as, MonadUnify m) =>+                    SrcLoc -> TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as+                 -> m (TypeBase (DimDecl VName) as, [VName])+newDimOnMismatch loc t1 t2 = do+  (t, seen) <- runStateT (matchDims onDims t1 t2) mempty+  return (t, M.elems seen)+  where r = Rigid $ RigidCond (toStruct t1) (toStruct t2)+        onDims d1 d2+          | d1 == d2 = return d1+          | otherwise = do+              -- Remember mismatches we have seen before and reuse the+              -- same new size.+              maybe_d <- gets $ M.lookup (d1, d2)+              case maybe_d of+                Just d -> return $ NamedDim $ qualName d+                Nothing -> do+                  d <- lift $ newDimVar loc r "differ"+                  modify $ M.insert (d1, d2) d+                  return $ NamedDim $ qualName d++-- | Like unification, but creates new size variables where mismatches+-- occur.  Returns the new dimensions thus created.+unifyMostCommon :: MonadUnify m =>+                   Usage -> PatternType -> PatternType -> m (PatternType, [VName])+unifyMostCommon usage t1 t2 = do+  -- We are ignoring the dimensions here, because any mismatches+  -- should be turned into fresh size variables.+  unify usage (toStruct (anySizes t1))+              (toStruct (anySizes t2))+  t1' <- normTypeFully t1+  t2' <- normTypeFully t2+  newDimOnMismatch (srclocOf usage) t1' t2'+ -- Simple MonadUnify implementation.  type UnifyMState = (Constraints, Int)@@ -495,20 +873,41 @@             MonadState UnifyMState,             MonadError TypeError) +newVar :: String -> UnifyM VName+newVar name = do+  (x, i) <- get+  put (x, i+1)+  return $ VName (mkTypeVarName name i) i+ instance MonadUnify UnifyM where   getConstraints = gets fst   putConstraints x = modify $ \(_, i) -> (x, i) -  newTypeVar loc desc = do-    i <- do (x, i) <- get-            put (x, i+1)-            return i-    let v = VName (mkTypeVarName desc i) 0+  newTypeVar loc name = do+    v <- newVar name     modifyConstraints $ M.insert v (0, NoConstraint Lifted $ Usage Nothing loc)     return $ Scalar $ TypeVar mempty Nonunique (typeName v) [] +  newDimVar loc rigidity name = do+    dim <- newVar name+    case rigidity of+      Rigid src -> modifyConstraints $ M.insert dim (0, UnknowableSize loc src)+      Nonrigid -> modifyConstraints $ M.insert dim (0, Size Nothing $ Usage Nothing loc)+    return dim+   curLevel = pure 0 +  unifyError loc notes bcs doc =+    throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs++  matchError loc notes bcs t1 t2 =+    throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+    where doc = "Types" </>+                indent 2 (ppr t1) </>+                "and" </>+                indent 2 (ppr t2) </>+                "do not match."+ -- | Construct a the name of a new type variable given a base -- description and a tag number (note that this is distinct from -- actually constructing a VName; the tag here is intended for human@@ -518,20 +917,21 @@   nameFromString $ desc ++ mapMaybe subscript (show i)   where subscript = flip lookup $ zip "0123456789" "₀₁₂₃₄₅₆₇₈₉" -instance MonadBreadCrumbs UnifyM where+runUnifyM :: [TypeParam] -> UnifyM a -> Either TypeError a+runUnifyM tparams (UnifyM m) = runExcept $ evalStateT m (constraints, 0)+  where constraints = M.fromList $ map f tparams+        f (TypeParamDim p loc) = (p, (0, Size Nothing $ Usage Nothing loc))+        f (TypeParamType l p loc) = (p, (0, NoConstraint l $ Usage Nothing loc))  -- | Perform a unification of two types outside a monadic context.--- The type parameters are allowed to be instantiated (with--- 'TypeParamDim ignored); all other types are considered rigid.+-- The type parameters are allowed to be instantiated; all other types+-- are considered rigid. doUnification :: SrcLoc -> [TypeParam]-              -> TypeBase () () -> TypeBase () ()-              -> Either TypeError (TypeBase () ())+              -> StructType -> StructType+              -> Either TypeError StructType doUnification loc tparams t1 t2 = runUnifyM tparams $ do-  unify (Usage Nothing loc) t1 t2-  normaliseType t2--runUnifyM :: [TypeParam] -> UnifyM a -> Either TypeError a-runUnifyM tparams (UnifyM m) = runExcept $ evalStateT m (constraints, 0)-  where constraints = M.fromList $ mapMaybe f tparams-        f TypeParamDim{} = Nothing-        f (TypeParamType l p loc) = Just (p, (0, NoConstraint l $ Usage Nothing loc))+  let rsrc = RigidUnify+  (t1', _) <- instantiateEmptyArrayDims loc "n" (Rigid rsrc) t1+  (t2', _) <- instantiateEmptyArrayDims loc "m" (Rigid rsrc) t2+  expect (Usage Nothing loc) t1' t2'+  normTypeFully t2
src/futhark.hs view
@@ -27,6 +27,7 @@ import qualified Futhark.CLI.CSOpenCL as CSOpenCL import qualified Futhark.CLI.Test as Test import qualified Futhark.CLI.Bench as Bench+import qualified Futhark.CLI.Check as Check import qualified Futhark.CLI.Dataset as Dataset import qualified Futhark.CLI.Datacmp as Datacmp import qualified Futhark.CLI.Pkg as Pkg@@ -66,7 +67,7 @@            , ("doc", (Doc.main, "Generate documentation for Futhark code."))            , ("pkg", (Pkg.main, "Manage local packages.")) -           , ("check", (Misc.mainCheck, "Type check a program."))+           , ("check", (Check.main, "Type check a program."))            , ("imports", (Misc.mainImports, "Print all non-builtin imported Futhark files."))            , ("autotune", (Autotune.main, "Autotune threshold parameters."))            , ("query", (Query.main, "Query semantic information about program."))