diff --git a/docs/binary-data-format.rst b/docs/binary-data-format.rst new file mode 100644 --- /dev/null +++ b/docs/binary-data-format.rst @@ -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 + +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 0 + +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 ... + + +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. diff --git a/docs/c-porting-guide.rst b/docs/c-porting-guide.rst new file mode 100644 --- /dev/null +++ b/docs/c-porting-guide.rst @@ -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). diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -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) diff --git a/docs/hacking.rst b/docs/hacking.rst new file mode 100644 --- /dev/null +++ b/docs/hacking.rst @@ -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. diff --git a/docs/installation.rst b/docs/installation.rst new file mode 100644 --- /dev/null +++ b/docs/installation.rst @@ -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 `_. 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 +`_ 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 +`_, 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 `_ + +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 + `_. + +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 + `_. ``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 diff --git a/docs/language-reference.rst b/docs/language-reference.rst new file mode 100644 --- /dev/null +++ b/docs/language-reference.rst @@ -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 +`_. + +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: + +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 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.. 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..`. + +Complex ranges +.............. + +Most complex ranges, such as ``a..` and :ref:`"upto" +ranges `. + +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" diff --git a/docs/man/futhark-bench.rst b/docs/man/futhark-bench.rst --- a/docs/man/futhark-bench.rst +++ b/docs/man/futhark-bench.rst @@ -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 diff --git a/docs/man/futhark-c.rst b/docs/man/futhark-c.rst --- a/docs/man/futhark-c.rst +++ b/docs/man/futhark-c.rst @@ -51,6 +51,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-csharp.rst b/docs/man/futhark-csharp.rst --- a/docs/man/futhark-csharp.rst +++ b/docs/man/futhark-csharp.rst @@ -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. diff --git a/docs/man/futhark-csopencl.rst b/docs/man/futhark-csopencl.rst --- a/docs/man/futhark-csopencl.rst +++ b/docs/man/futhark-csopencl.rst @@ -51,6 +51,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-cuda.rst b/docs/man/futhark-cuda.rst --- a/docs/man/futhark-cuda.rst +++ b/docs/man/futhark-cuda.rst @@ -53,6 +53,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-opencl.rst b/docs/man/futhark-opencl.rst --- a/docs/man/futhark-opencl.rst +++ b/docs/man/futhark-opencl.rst @@ -53,6 +53,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-pyopencl.rst b/docs/man/futhark-pyopencl.rst --- a/docs/man/futhark-pyopencl.rst +++ b/docs/man/futhark-pyopencl.rst @@ -60,6 +60,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-python.rst b/docs/man/futhark-python.rst --- a/docs/man/futhark-python.rst +++ b/docs/man/futhark-python.rst @@ -54,6 +54,9 @@ -V Print version information on standard output and exit. +-W + Do not print any warnings. + --Werror Treat warnings as errors. diff --git a/docs/man/futhark-test.rst b/docs/man/futhark-test.rst --- a/docs/man/futhark-test.rst +++ b/docs/man/futhark-test.rst @@ -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 diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -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 ----------------------------- diff --git a/docs/package-management.rst b/docs/package-management.rst new file mode 100644 --- /dev/null +++ b/docs/package-management.rst @@ -0,0 +1,361 @@ +.. _package-management: + +Package Management +================== + +This document describes ``futhark pkg``, a minimalistic package +manager inspired by `vgo `_. A +Futhark package is a downloadable collection of ``.fut`` files and +little more. There is a (not necessarily comprehensive) `list of +known packages `_. + +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 +`_ 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 +`_, 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 `_. See `this +page +`_ +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 `_, 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 `_. + +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 +`_. 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. diff --git a/docs/requirements.txt b/docs/requirements.txt new file mode 100644 --- /dev/null +++ b/docs/requirements.txt @@ -0,0 +1,1 @@ +pyyaml>=4.2b1 diff --git a/docs/usage.rst b/docs/usage.rst new file mode 100644 --- /dev/null +++ b/docs/usage.rst @@ -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 +`_ 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 +`_ 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 + `_. + +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 `_ +type. Scalars are mapped to Numpy scalar types. diff --git a/docs/versus-other-languages.rst b/docs/versus-other-languages.rst new file mode 100644 --- /dev/null +++ b/docs/versus-other-languages.rst @@ -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. diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/futlib/array.fut b/futlib/array.fut deleted file mode 100644 --- a/futlib/array.fut +++ /dev/null @@ -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) diff --git a/futlib/functional.fut b/futlib/functional.fut deleted file mode 100644 --- a/futlib/functional.fut +++ /dev/null @@ -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 diff --git a/futlib/math.fut b/futlib/math.fut deleted file mode 100644 --- a/futlib/math.fut +++ /dev/null @@ -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..> (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..> (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..> (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..> (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..> (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..> (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..> (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.. (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 -} diff --git a/futlib/prelude.fut b/futlib/prelude.fut deleted file mode 100644 --- a/futlib/prelude.fut +++ /dev/null @@ -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 diff --git a/futlib/soacs.fut b/futlib/soacs.fut deleted file mode 100644 --- a/futlib/soacs.fut +++ /dev/null @@ -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) diff --git a/futlib/zip.fut b/futlib/zip.fut deleted file mode 100644 --- a/futlib/zip.fut +++ /dev/null @@ -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) diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -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 diff --git a/prelude/array.fut b/prelude/array.fut new file mode 100644 --- /dev/null +++ b/prelude/array.fut @@ -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) diff --git a/prelude/functional.fut b/prelude/functional.fut new file mode 100644 --- /dev/null +++ b/prelude/functional.fut @@ -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 diff --git a/prelude/math.fut b/prelude/math.fut new file mode 100644 --- /dev/null +++ b/prelude/math.fut @@ -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..> (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..> (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..> (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..> (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..> (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..> (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..> (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.. (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 +} diff --git a/prelude/prelude.fut b/prelude/prelude.fut new file mode 100644 --- /dev/null +++ b/prelude/prelude.fut @@ -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 diff --git a/prelude/soacs.fut b/prelude/soacs.fut new file mode 100644 --- /dev/null +++ b/prelude/soacs.fut @@ -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 diff --git a/prelude/zip.fut b/prelude/zip.fut new file mode 100644 --- /dev/null +++ b/prelude/zip.fut @@ -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) diff --git a/rts/c/cuda.h b/rts/c/cuda.h --- a/rts/c/cuda.h +++ b/rts/c/cuda.h @@ -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; diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -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); \ } \ } \ } diff --git a/rts/csharp/scalar.cs b/rts/csharp/scalar.cs --- a/rts/csharp/scalar.cs +++ b/rts/csharp/scalar.cs @@ -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);} diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -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)) diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -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. diff --git a/src/Futhark/Analysis/Alias.hs b/src/Futhark/Analysis/Alias.hs --- a/src/Futhark/Analysis/Alias.hs +++ b/src/Futhark/Analysis/Alias.hs @@ -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) diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs --- a/src/Futhark/Analysis/CallGraph.hs +++ b/src/Futhark/Analysis/CallGraph.hs @@ -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 diff --git a/src/Futhark/Analysis/HORepresentation/SOAC.hs b/src/Futhark/Analysis/HORepresentation/SOAC.hs --- a/src/Futhark/Analysis/HORepresentation/SOAC.hs +++ b/src/Futhark/Analysis/HORepresentation/SOAC.hs @@ -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 diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -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 diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -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 diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs --- a/src/Futhark/Analysis/PrimExp/Convert.hs +++ b/src/Futhark/Analysis/PrimExp/Convert.hs @@ -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 diff --git a/src/Futhark/Analysis/PrimExp/Generalize.hs b/src/Futhark/Analysis/PrimExp/Generalize.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Analysis/PrimExp/Generalize.hs @@ -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)]) diff --git a/src/Futhark/Analysis/Range.hs b/src/Futhark/Analysis/Range.hs --- a/src/Futhark/Analysis/Range.hs +++ b/src/Futhark/Analysis/Range.hs @@ -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 diff --git a/src/Futhark/Analysis/Rephrase.hs b/src/Futhark/Analysis/Rephrase.hs --- a/src/Futhark/Analysis/Rephrase.hs +++ b/src/Futhark/Analysis/Rephrase.hs @@ -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 diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -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) diff --git a/src/Futhark/Analysis/Usage.hs b/src/Futhark/Analysis/Usage.hs --- a/src/Futhark/Analysis/Usage.hs +++ b/src/Futhark/Analysis/Usage.hs @@ -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 diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -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 () diff --git a/src/Futhark/Binder.hs b/src/Futhark/Binder.hs --- a/src/Futhark/Binder.hs +++ b/src/Futhark/Binder.hs @@ -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 diff --git a/src/Futhark/Binder/Class.hs b/src/Futhark/Binder/Class.hs --- a/src/Futhark/Binder/Class.hs +++ b/src/Futhark/Binder/Class.hs @@ -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)) diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs --- a/src/Futhark/CLI/Autotune.hs +++ b/src/Futhark/CLI/Autotune.hs @@ -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 = diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -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}) diff --git a/src/Futhark/CLI/Check.hs b/src/Futhark/CLI/Check.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Check.hs @@ -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 diff --git a/src/Futhark/CLI/Dataset.hs b/src/Futhark/CLI/Dataset.hs --- a/src/Futhark/CLI/Dataset.hs +++ b/src/Futhark/CLI/Dataset.hs @@ -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." diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -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 diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs --- a/src/Futhark/CLI/Misc.hs +++ b/src/Futhark/CLI/Misc.hs @@ -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 diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -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 } diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs --- a/src/Futhark/CLI/Run.hs +++ b/src/Futhark/CLI/Run.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -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|]) diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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 ") $esc:("#include ") @@ -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));|] diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -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 ", "#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| diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -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") diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL.hs b/src/Futhark/CodeGen/Backends/CSOpenCL.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL.hs @@ -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" diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs @@ -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)) [] diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -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" diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp.hs b/src/Futhark/CodeGen/Backends/GenericCSharp.hs --- a/src/Futhark/CodeGen/Backends/GenericCSharp.hs +++ b/src/Futhark/CodeGen/Backends/GenericCSharp.hs @@ -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] diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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 () diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -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"]] [] diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs b/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs --- a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs @@ -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") |] diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpCode/Kernels.hs b/src/Futhark/CodeGen/ImpCode/Kernels.hs --- a/src/Futhark/CodeGen/ImpCode/Kernels.hs +++ b/src/Futhark/CodeGen/ImpCode/Kernels.hs @@ -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]) diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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. diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs @@ -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." diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs @@ -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) [] diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs @@ -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. diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs @@ -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 = diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -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." diff --git a/src/Futhark/Compiler/CLI.hs b/src/Futhark/Compiler/CLI.hs --- a/src/Futhark/Compiler/CLI.hs +++ b/src/Futhark/Compiler/CLI.hs @@ -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 } diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -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] diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -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)) diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -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 = diff --git a/src/Futhark/Error.hs b/src/Futhark/Error.hs --- a/src/Futhark/Error.hs +++ b/src/Futhark/Error.hs @@ -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 diff --git a/src/Futhark/FreshNames.hs b/src/Futhark/FreshNames.hs --- a/src/Futhark/FreshNames.hs +++ b/src/Futhark/FreshNames.hs @@ -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 diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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) diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs --- a/src/Futhark/Internalise/AccurateSizes.hs +++ b/src/Futhark/Internalise/AccurateSizes.hs @@ -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)) diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -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) = diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -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' diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -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)) = diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs --- a/src/Futhark/Internalise/Lambdas.hs +++ b/src/Futhark/Internalise/Lambdas.hs @@ -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 diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -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. diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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 () diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -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 diff --git a/src/Futhark/Optimise/Fusion/TryFusion.hs b/src/Futhark/Optimise/Fusion/TryFusion.hs --- a/src/Futhark/Optimise/Fusion/TryFusion.hs +++ b/src/Futhark/Optimise/Fusion/TryFusion.hs @@ -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) diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -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 diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs --- a/src/Futhark/Optimise/Sink.hs +++ b/src/Futhark/Optimise/Sink.hs @@ -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) diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -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 diff --git a/src/Futhark/Pass.hs b/src/Futhark/Pass.hs --- a/src/Futhark/Pass.hs +++ b/src/Futhark/Pass.hs @@ -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') diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -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 diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs --- a/src/Futhark/Pass/ExplicitAllocations.hs +++ b/src/Futhark/Pass/ExplicitAllocations.hs @@ -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 (( 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] diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/Distribution.hs b/src/Futhark/Pass/ExtractKernels/Distribution.hs --- a/src/Futhark/Pass/ExtractKernels/Distribution.hs +++ b/src/Futhark/Pass/ExtractKernels/Distribution.hs @@ -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 }, diff --git a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs --- a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs +++ b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs @@ -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) = diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs --- a/src/Futhark/Pass/KernelBabysitting.hs +++ b/src/Futhark/Pass/KernelBabysitting.hs @@ -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 diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -35,6 +35,7 @@ standardPipeline = passes [ simplifySOACS , inlineAndRemoveDeadFunctions + , simplifySOACS , performCSE True , simplifySOACS -- We run fusion twice diff --git a/src/Futhark/Representation/AST/Attributes.hs b/src/Futhark/Representation/AST/Attributes.hs --- a/src/Futhark/Representation/AST/Attributes.hs +++ b/src/Futhark/Representation/AST/Attributes.hs @@ -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) diff --git a/src/Futhark/Representation/AST/Attributes/Names.hs b/src/Futhark/Representation/AST/Attributes/Names.hs --- a/src/Futhark/Representation/AST/Attributes/Names.hs +++ b/src/Futhark/Representation/AST/Attributes/Names.hs @@ -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] diff --git a/src/Futhark/Representation/AST/Attributes/Scope.hs b/src/Futhark/Representation/AST/Attributes/Scope.hs --- a/src/Futhark/Representation/AST/Attributes/Scope.hs +++ b/src/Futhark/Representation/AST/Attributes/Scope.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Attributes/TypeOf.hs b/src/Futhark/Representation/AST/Attributes/TypeOf.hs --- a/src/Futhark/Representation/AST/Attributes/TypeOf.hs +++ b/src/Futhark/Representation/AST/Attributes/TypeOf.hs @@ -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. diff --git a/src/Futhark/Representation/AST/Pretty.hs b/src/Futhark/Representation/AST/Pretty.hs --- a/src/Futhark/Representation/AST/Pretty.hs +++ b/src/Futhark/Representation/AST/Pretty.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Syntax.hs b/src/Futhark/Representation/AST/Syntax.hs --- a/src/Futhark/Representation/AST/Syntax.hs +++ b/src/Futhark/Representation/AST/Syntax.hs @@ -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) diff --git a/src/Futhark/Representation/AST/Syntax/Core.hs b/src/Futhark/Representation/AST/Syntax/Core.hs --- a/src/Futhark/Representation/AST/Syntax/Core.hs +++ b/src/Futhark/Representation/AST/Syntax/Core.hs @@ -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 diff --git a/src/Futhark/Representation/Aliases.hs b/src/Futhark/Representation/Aliases.hs --- a/src/Futhark/Representation/Aliases.hs +++ b/src/Futhark/Representation/Aliases.hs @@ -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') diff --git a/src/Futhark/Representation/ExplicitMemory.hs b/src/Futhark/Representation/ExplicitMemory.hs --- a/src/Futhark/Representation/ExplicitMemory.hs +++ b/src/Futhark/Representation/ExplicitMemory.hs @@ -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 diff --git a/src/Futhark/Representation/ExplicitMemory/IndexFunction.hs b/src/Futhark/Representation/ExplicitMemory/IndexFunction.hs --- a/src/Futhark/Representation/ExplicitMemory/IndexFunction.hs +++ b/src/Futhark/Representation/ExplicitMemory/IndexFunction.hs @@ -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) diff --git a/src/Futhark/Representation/Kernels/Kernel.hs b/src/Futhark/Representation/Kernels/Kernel.hs --- a/src/Futhark/Representation/Kernels/Kernel.hs +++ b/src/Futhark/Representation/Kernels/Kernel.hs @@ -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 diff --git a/src/Futhark/Representation/Kernels/Simplify.hs b/src/Futhark/Representation/Kernels/Simplify.hs --- a/src/Futhark/Representation/Kernels/Simplify.hs +++ b/src/Futhark/Representation/Kernels/Simplify.hs @@ -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 diff --git a/src/Futhark/Representation/Primitive.hs b/src/Futhark/Representation/Primitive.hs --- a/src/Futhark/Representation/Primitive.hs +++ b/src/Futhark/Representation/Primitive.hs @@ -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 diff --git a/src/Futhark/Representation/Ranges.hs b/src/Futhark/Representation/Ranges.hs --- a/src/Futhark/Representation/Ranges.hs +++ b/src/Futhark/Representation/Ranges.hs @@ -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) diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs --- a/src/Futhark/Test/Values.hs +++ b/src/Futhark/Test/Values.hs @@ -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 diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -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 diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -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 diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs --- a/src/Futhark/Util/Pretty.hs +++ b/src/Futhark/Util/Pretty.hs @@ -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 diff --git a/src/Language/Futhark/Attributes.hs b/src/Language/Futhark/Attributes.hs --- a/src/Language/Futhark/Attributes.hs +++ b/src/Language/Futhark/Attributes.hs @@ -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] diff --git a/src/Language/Futhark/Core.hs b/src/Language/Futhark/Core.hs --- a/src/Language/Futhark/Core.hs +++ b/src/Language/Futhark/Core.hs @@ -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 diff --git a/src/Language/Futhark/Futlib.hs b/src/Language/Futhark/Futlib.hs deleted file mode 100644 --- a/src/Language/Futhark/Futlib.hs +++ /dev/null @@ -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"] diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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 "#" - 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) diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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) diff --git a/src/Language/Futhark/Prelude.hs b/src/Language/Futhark/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/Prelude.hs @@ -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) diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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 diff --git a/src/Language/Futhark/Query.hs b/src/Language/Futhark/Query.hs --- a/src/Language/Futhark/Query.hs +++ b/src/Language/Futhark/Query.hs @@ -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 diff --git a/src/Language/Futhark/Semantic.hs b/src/Language/Futhark/Semantic.hs --- a/src/Language/Futhark/Semantic.hs +++ b/src/Language/Futhark/Semantic.hs @@ -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 diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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 diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs --- a/src/Language/Futhark/TypeChecker/Modules.hs +++ b/src/Language/Futhark/TypeChecker/Modules.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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 "") (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 + } diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -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 diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -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."))