futhark 0.18.5 → 0.18.6

raw patch · 113 files changed

+4605/−1201 lines, 113 filesdep +bytestring-to-vectordep ~megaparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring-to-vector

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• docs/c-api.rst +77/−14
• docs/conf.py +3/−1
• docs/index.rst +2/−0
• docs/man/futhark-c.rst +3/−0
• docs/man/futhark-cuda.rst +3/−0
• docs/man/futhark-literate.rst +195/−0
• docs/man/futhark-multicore.rst +3/−0
• docs/man/futhark-opencl.rst +3/−0
• docs/man/futhark-pyopencl.rst +3/−0
• docs/man/futhark-python.rst +3/−0
• docs/man/futhark-test.rst +2/−2
• docs/man/futhark.rst +1/−1
• docs/server-protocol.rst +110/−0
• docs/usage.rst +20/−12
• futhark.cabal +9/−2
• prelude/math.fut +35/−22
• rts/c/cuda.h +4/−4
• rts/c/scheduler.h +0/−3
• rts/c/server.h +630/−0
• rts/python/server.py +165/−0
• src/Futhark/Actions.hs +13/−0
• src/Futhark/Analysis/Metrics.hs +1/−18
• src/Futhark/Analysis/Metrics/Type.hs +26/−0
• src/Futhark/Analysis/PrimExp.hs +6/−6
• src/Futhark/Analysis/Rephrase.hs +0/−1
• src/Futhark/Analysis/SymbolTable.hs +0/−1
• src/Futhark/Bench.hs +88/−157
• src/Futhark/CLI/Autotune.hs +36/−33
• src/Futhark/CLI/Bench.hs +45/−18
• src/Futhark/CLI/Check.hs +0/−1
• src/Futhark/CLI/Dataset.hs +12/−13
• src/Futhark/CLI/Dev.hs +21/−6
• src/Futhark/CLI/Doc.hs +1/−2
• src/Futhark/CLI/Literate.hs +742/−0
• src/Futhark/CLI/Multicore.hs +2/−0
• src/Futhark/CLI/Pkg.hs +0/−1
• src/Futhark/CLI/PyOpenCL.hs +4/−4
• src/Futhark/CLI/Python.hs +4/−4
• src/Futhark/CLI/REPL.hs +2/−3
• src/Futhark/CLI/Run.hs +1/−2
• src/Futhark/CLI/Test.hs +164/−133
• src/Futhark/CodeGen/Backends/CCUDA.hs +7/−6
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +8/−9
• src/Futhark/CodeGen/Backends/COpenCL.hs +8/−7
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +8/−11
• src/Futhark/CodeGen/Backends/GenericC.hs +180/−26
• src/Futhark/CodeGen/Backends/GenericC/CLI.hs +9/−9
• src/Futhark/CodeGen/Backends/GenericC/Server.hs +282/−0
• src/Futhark/CodeGen/Backends/GenericPython.hs +136/−64
• src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs +4/−0
• src/Futhark/CodeGen/Backends/MulticoreC.hs +8/−2
• src/Futhark/CodeGen/Backends/PyOpenCL.hs +8/−10
• src/Futhark/CodeGen/Backends/SequentialC.hs +5/−8
• src/Futhark/CodeGen/Backends/SequentialPython.hs +8/−5
• src/Futhark/CodeGen/Backends/SimpleRep.hs +87/−0
• src/Futhark/CodeGen/ImpCode.hs +4/−4
• src/Futhark/CodeGen/ImpGen.hs +1/−1
• src/Futhark/CodeGen/ImpGen/CUDA.hs +2/−0
• src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +3/−0
• src/Futhark/CodeGen/ImpGen/Multicore.hs +1/−0
• src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +2/−2
• src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +1/−0
• src/Futhark/CodeGen/ImpGen/OpenCL.hs +2/−0
• src/Futhark/Compiler.hs +11/−15
• src/Futhark/Compiler/CLI.hs +31/−7
• src/Futhark/Compiler/Program.hs +122/−124
• src/Futhark/Construct.hs +0/−1
• src/Futhark/Error.hs +0/−1
• src/Futhark/IR.hs +0/−2
• src/Futhark/IR/Mem.hs +15/−15
• src/Futhark/IR/Mem/IxFun.hs +4/−4
• src/Futhark/IR/Primitive.hs +0/−1
• src/Futhark/IR/Prop.hs +0/−1
• src/Futhark/IR/Prop/Names.hs +0/−1
• src/Futhark/IR/Prop/Types.hs +1/−1
• src/Futhark/IR/SOACS.hs +0/−1
• src/Futhark/IR/SOACS/Simplify.hs +0/−1
• src/Futhark/IR/Syntax/Core.hs +0/−1
• src/Futhark/IR/Traversals.hs +0/−2
• src/Futhark/Internalise.hs +10/−4
• src/Futhark/Internalise/Bindings.hs +0/−1
• src/Futhark/Internalise/LiftLambdas.hs +2/−0
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +9/−1
• src/Futhark/Optimise/Simplify/ClosedForm.hs +0/−1
• src/Futhark/Optimise/Simplify/Engine.hs +1/−0
• src/Futhark/Optimise/Simplify/Rules.hs +4/−1
• src/Futhark/Optimise/TileLoops.hs +17/−12
• src/Futhark/Pass/ExpandAllocations.hs +3/−1
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +10/−2
• src/Futhark/Script.hs +305/−0
• src/Futhark/Server.hs +175/−0
• src/Futhark/Test.hs +148/−212
• src/Futhark/Test/Values.hs +319/−120
• src/Futhark/Test/Values/Parser.hs +167/−0
• src/Futhark/Transform/Substitute.hs +1/−2
• src/Futhark/Util/Options.hs +1/−0
• src/Futhark/Util/Pretty.hs +5/−0
• src/Language/Futhark.hs +0/−2
• src/Language/Futhark/Interpreter.hs +8/−7
• src/Language/Futhark/Parser.hs +0/−2
• src/Language/Futhark/Prop.hs +6/−3
• src/Language/Futhark/Semantic.hs +0/−2
• src/Language/Futhark/Syntax.hs +0/−1
• src/Language/Futhark/TypeChecker.hs +5/−11
• src/Language/Futhark/TypeChecker/Match.hs +2/−0
• src/Language/Futhark/TypeChecker/Modules.hs +0/−1
• src/Language/Futhark/TypeChecker/Monad.hs +1/−1
• src/Language/Futhark/TypeChecker/Terms.hs +2/−2
• src/Language/Futhark/TypeChecker/Types.hs +0/−1
• src/Language/Futhark/Warnings.hs +0/−2
• src/futhark.hs +3/−1
• unittests/Futhark/BenchTests.hs +3/−1

@@ -117,6 +117,13 @@    subsequent call to the function returns ``NULL``, until a new error    occurs. +.. c:function:: void futhark_context_set_logging_file(struct futhark_context *ctx, FILE* f)++   Set the stream used to print diagnostics, debug prints, and logging+   messages during runtime.  This is ``stderr`` by default.  Even when+   this is used to re-route logging messages, fatal errors will still+   only be printed to ``stderr``.+ .. c:function:: char *futhark_context_report(struct futhark_context *ctx)     Produce a human-readable C string with debug and profiling@@ -139,21 +146,17 @@ ------  Primitive types (``i32``, ``bool``, etc) are mapped directly to their-corresponding C type.  For each distinct array type (without sizes),-an opaque C struct is defined.  Complex types (records, nested tuples)-are also assigned an opaque C struct.  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 C identifiers), 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.+corresponding C type.  For each distinct array type of primitives+(ignoring sizes), an opaque C struct is defined.  For types that do+not map cleanly to C, including records, sum types, and arrays of+tuples, see :ref:`opaques`. -All values share a similar API, which is illustrated here for the case-of the type ``[]i32``.  The creation/retrieval functions are all-asynchronous, so make sure to call :c:func:`futhark_context_sync` when-appropriate.  Memory management is entirely manual.  All values that-are created with a ``new`` function, or returned from an entry point,-*must* at some point be freed manually.  Values are internally+All array values share a similar API, which is illustrated here for+the case of the type ``[]i32``.  The creation/retrieval functions are+all asynchronous, so make sure to call :c:func:`futhark_context_sync`+when appropriate.  Memory management is entirely manual.  All values+that are created with a ``new`` function, or returned from an entry+point, *must* at some point be freed manually.  Values are internally reference counted, so even for entry points that return their input unchanged, you should still free both the input and the output - this will not result in a double free.@@ -195,6 +198,66 @@    Return a pointer to the shape of the array, with one element per    dimension.  The lifetime of the shape is the same as ``arr``, and    should *not* be manually freed.++.. _opaques:++Opaque values+~~~~~~~~~~~~~++Each instance of a complex type in an entry point (records, nested+tuples, etc) is represented by an opaque C struct named+``futhark_opaque_foo``.  In the general case, ``foo`` will be a hash+of the internal representation.  However, if you insert explicit type+annotations in the entry point (and the type name contains only+characters valid for C identifiers), the indicated name will be used.+Note that arrays contain brackets, which are usually not valid in+identifiers.  Defining a simple type abbreviation is the best way+around this.++The API for opaque values is similar to that of arrays, and the same+rules for memory management apply.  You cannot construct them from+scratch, but must obtain them via entry points (or deserialisation,+see :c:func:`futhark_restore_opaque_foo`).++.. c:struct:: futhark_opaque_foo++   An opaque struct representing a Futhark value of type ``foo``.++.. c:function:: int futhark_free_opaque_foo(struct futhark_context *ctx, struct futhark_opaque_foo *obj)++   Free the value.  In practice, this merely decrements the reference+   count by one.  The value (or at least this reference) may not be+   used again after this function returns.++.. c:function:: int futhark_store_opaque_foo(struct futhark_context *ctx, const struct futhark_opaque_foo *obj, void **p, size_t *n);++   Serialise an opaque value to a byte sequence, which can later be+   restored with :c:func:`futhark_restore_opaque_foo`.  The byte+   representation is not otherwise specified.  The variable pointed to+   by ``n`` will always be set to the number of bytes needed to+   represent the value.  The ``p`` parameter is more complex:++   * If ``p`` is ``NULL``, the function will write to ``*n``, but not+     actually serialise the opaque value.++   * If ``*p`` is ``NULL``, the function will allocate sufficient+     storage with ``malloc()``, serialise the value, and write the+     address of the byte representation to ``*p``.++   * Otherwise, the serialised representation of the value will be+     stored at ``*p``, which *must* have room for at least ``*n``+     bytes.++   Returns 0 on success.++.. c:function:: struct futhark_opaque_foo* futhark_restore_opaque_foo(struct futhark_context *ctx, const void *p);++   Restore a byte sequence previously written with+   :c:func:`futhark_store_opaque_foo`.  Returns ``NULL`` on failure.+   The byte sequence does not need to have been generated by the same+   program *instance*, but it *must* have been generated by the same+   Futhark program, and compiled with the same version of the Futhark+   compiler.  Entry points ------------

@@ -261,6 +261,7 @@ # (source start file, name, description, authors, manual section). man_pages = [     ('man/futhark', 'futhark', 'a parallel functional array language', [], 1),+    ('man/futhark-autotune', 'futhark-autotune', 'calibrate run-time parameters', [], 1),     ('man/futhark-c', 'futhark-c', 'compile Futhark to sequential C', [], 1),     ('man/futhark-multicore', 'futhark-multicore', 'compile Futhark to multithreaded C', [], 1),     ('man/futhark-opencl', 'futhark-opencl', 'compile Futhark to OpenCL', [], 1),@@ -273,7 +274,8 @@     ('man/futhark-bench', 'futhark-bench', 'benchmark Futhark programs', [], 1),     ('man/futhark-doc', 'futhark-doc', 'generate documentation for Futhark code', [], 1),     ('man/futhark-dataset', 'futhark-dataset', 'generate random data sets', [], 1),-    ('man/futhark-pkg', 'futhark-pkg', 'manage Futhark packages', [], 1)+    ('man/futhark-pkg', 'futhark-pkg', 'manage Futhark packages', [], 1),+    ('man/futhark-literate', 'futhark-literate', 'execute literate Futhark program', [], 1) ]  # If true, show URL addresses after external links.

@@ -32,6 +32,7 @@    language-reference.rst    c-api.rst    package-management.rst+   server-protocol.rst    c-porting-guide.rst    versus-other-languages.rst    hacking.rst@@ -55,4 +56,5 @@    man/futhark-python.rst    man/futhark-repl.rst    man/futhark-run.rst+   man/futhark-literate.rst    man/futhark-test.rst

@@ -31,6 +31,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Generate a library instead of an executable.  Appends ``.c``/``.h``   to the name indicated by the ``-o`` option to determine output

@@ -35,6 +35,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Generate a library instead of an executable.  Appends ``.c``/``.h``   to the name indicated by the ``-o`` option to determine output

@@ -0,0 +1,195 @@+.. role:: ref(emphasis)++.. _futhark-literate(1):++================+futhark-literate+================++SYNOPSIS+========++futhark literate [options...] program++DESCRIPTION+===========++The command ``futhark literate foo.fut`` will compile the given+program and then generate a Markdown file ``foo.md`` that contains a+prettyprinted form of the program.  This is useful for demonstrating+programming techniques.++* Top-level comments that start with a line comment marker (``--``)+  and a space in the first column will be turned into ordinary text in+  the Markdown file.++* Ordinary top-level definitions will be enclosed in Markdown code+  blocks.++* Any *directives* will be executed and replaced with their output.+  See below.++**Warning:** Do not run untrusted programs.  See SECURITY below.++Directives+==========++A directive is a way to embed the results the running the program.+Depending on the directive, this can be as simple as printing the+textual representation of the result, or as complex as running an+external plotting program and referencing a generated image.++Any directives that produce images for a program ``foo.fut`` will+place them in the directory ``foo-img/``.  If this directory already+exists, it will be deleted.++A directive is a line starting with ``-- >``, which must follow an+empty line.  Arguments to the directive follow on the remainder of the+line.  Any expression arguments are given in a very restricted subset+of Futhark called *FutharkScript* (see below).++Some directives take mandatory or optional parameters.  These are+entered after a semicolon *and a linebreak*.++The following directives are supported:++* ``> e``++  Shows the result of executing the FutharkScript expression ``e``,+  which can have any (transparent) type.++* ``> :anim e[; parameters...]``++  Creates a video from ``e``.  The optional parameters are lines of+  the form *key: value*:++  * ``repeat: <true|false>``++  * ``fps: <int>``++  * ``format: <webm|gif>``++  Shells out to ``ffmpeg`` to actually create the video file.++  ``e`` must be one of the following:++  * A 3D array where the 2D elements is of a type acceptable to+    ``:img``, and the outermost dimension is the number of frames.++  * A triple ``(s -> (img,s), s, i64)``, for some types ``s`` and+    ``img``, where ``img`` is an array acceptable to ``:img``.  This+    means not all frames have to be held in memory at once.++* ``> :brief <directive>``++  The same as the given *directive* (which must not start with another+  ``>``), but suppress parameters when printing it.++* ``> :covert <directive>``++  The same as the given *directive* (which must not start with another+  ``>``), but do not show the directive itself in the output, only its+  result.++* ``> :img e``++  Visualises ``e``, which must be of type ``[][]i32`` or ``[][]u32``+  (interpreted as rows of ARGB pixel values).  Shells out to+  ``convert`` (from ImageMagick) to generate the image.++* ``> :plot2d e[; size=(height,width)]``++  Shows a plot generated with ``gnuplot`` of ``e``, which must be an+  expression of type ``([]t, []t)``, where ``t`` is some numeric type.+  The two arrays must have the same length and are interpreted as+  ``x`` and ``y`` values, respectively.++  The expression may also be a record, where each field will be+  plotted separately and must have the type mentioned above.++* ``> :gnuplot e; script...``++  Similar to ``plot2d``, except that it uses the provided Gnuplot+  script.  The ``e`` argument must be a record whose fields are tuples+  of one-dimensional arrays, and the data will be available in+  temporary files whose names are in variables named after the record+  fields.  Each file will contain a column of data for each array in+  the corresponding tuple.++  Use ``set term png size width,height`` to change the size to+  ``width`` by ``height`` pixels.++FutharkScript+=============++Only an extremely limited subset of Futhark is supported:++.. productionlist::+   scriptexp:   `id` `scriptexp`*+            : | "(" `scriptexp` ")"+            : | "(" `scriptexp` ( "," `scriptexp` )+ ")"+            : | "{" "}"+            : | "{" (`id` = `scriptexp`) ("," `id` = `scriptexp`)* "}"+            : | `literal`++Any numeric literals *must* have a type suffix.++OPTIONS+=======++--backend=name++  The backend used when compiling Futhark programs (without leading+  ``futhark``, e.g. just ``opencl``).  Defaults to ``c``.++--futhark=program++  The program used to perform operations (eg. compilation).  Defaults+  to the binary running ``futhark literate`` itself.++--output=FILE++  Override the default output file.  The image directory will be set+  to the provided ``FILE`` with its extension stripped and ``-img/``+  appended.++--pass-option=opt++  Pass an option to benchmark programs that are being run.  For+  example, we might want to run OpenCL programs on a specific device::++    futhark literate prog.fut --backend=opencl --pass-option=-dHawaii++--pass-compiler-option=opt++  Pass an extra option to the compiler when compiling the programs.++--skip-compilation++  Do not run the compiler, and instead assume that the program has+  already been compiled.  Use with caution.++--stop-on-error++  Terminate immediately without producing an output file if a+  directive fails.  Otherwise a file will still be produced, and+  failing directives will be followed by an error message.++-v, --verbose++  Print verbose information on stderr about directives as they are+  executing.++SECURITY+========++Some directives (e.g. ``:gnuplot``) can run arbitrary shell commands.+Running an untrusted literate Futhark program is as dangerous as+running a shell script you downloaded off the Internet.  Before+running a program from an unknown source, you should always give it a+quick read to see if anything looks fishy.++SEE ALSO+========++:ref:`futhark-test(1)`, :ref:`futhark-bench(1)`

@@ -31,6 +31,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Generate a library instead of an executable.  Appends ``.c``/``.h``   to the name indicated by the ``-o`` option to determine output

@@ -31,6 +31,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Generate a library instead of an executable.  Appends ``.c``/``.h``   to the name indicated by the ``-o`` option to determine output

@@ -37,6 +37,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Instead of compiling to an executable program, generate a Python   module that can be imported by other Python code.  The module will

@@ -31,6 +31,9 @@ -h   Print help text to standard output and exit. +--entry NAME+  Treat the specified top-level function as an entry point.+ --library   Instead of compiling to an executable program, generate a Python   module that can be imported by other Python code.  The module will

@@ -20,8 +20,8 @@  A Futhark test program is an ordinary Futhark program, with at least one test block describing input/output test cases and possibly other-options.  A test block consists of commented-out text with the-following overall format::+options.  The last line must end in a newline.  A test block consists+of commented-out text with the following overall format::    description   ==

@@ -68,4 +68,4 @@ SEE ALSO ======== -:ref:`futhark-opencl(1)`, :ref:`futhark-c(1)`, :ref:`futhark-py(1)`, :ref:`futhark-pyopencl(1)`, :ref:`futhark-dataset(1)`, :ref:`futhark-doc(1)`, :ref:`futhark-test(1)`, :ref:`futhark-bench(1)`, :ref:`futhark-run(1)`, :ref:`futhark-repl(1)`+:ref:`futhark-opencl(1)`, :ref:`futhark-c(1)`, :ref:`futhark-py(1)`, :ref:`futhark-pyopencl(1)`, :ref:`futhark-dataset(1)`, :ref:`futhark-doc(1)`, :ref:`futhark-test(1)`, :ref:`futhark-bench(1)`, :ref:`futhark-run(1)`, :ref:`futhark-repl(1)`, :ref:`futhark-literate(1)`

@@ -0,0 +1,110 @@+.. _server-protocol:++Server Protocol+===============++A Futhark program can be compiled to a *server executable*.  Such a+server maintains a Futhark context and presents a line-oriented+interface (over stdin/stdout) for loading and dumping values, as well+as calling the entry points in the program.  The main advantage over+the plain executable interface is that program initialisation is done+only *once*, and we can work with opaque values.++The server interface is not intended for human consumption, but is+useful for writing tools on top of Futhark programs, without having to+use the C API.  Futhark's built-in benchmarking and testing tools use+server executables.++A server executable is started like any other executable, and supports+most of the same command line options.++Basics+------++Each command is sent as a *single line* on standard input.  The+response is sent on standard output.  The server will print ``%%% OK``+on a line by itself to indicate that a command has finished.  If a+command fails, the server will print ``%%% FAILURE`` followed by the+error message, and then ``%%% OK`` when it is ready for more input.+Some output may also precede ``%%% FAILURE``, e.g. logging statements+that occured before failure was detected.  Fatal errors (that lead to+server shutdown) may be printed to stderr.++Variables+---------++Some commands produce or read variables.  A variable is a mapping from+a name to a Futhark value.  Values can be both transparent (arrays and+primitives), but they can also be *opaque* values.  These can be+produced by entry points and passed to other entry points, but cannot+be directly inspected.++Types+-----++All variables have types, and all entry points accept inputs and+produce outputs of defined types.  The notion of transparent and+opaque types are the same as in the C API: primitives and array of+primitives are directly supported, and everything else is treated as+opaque.  When printed, types follow basic Futhark type syntax+*without* sizes (e.g. ``[][]i32``).++Commands+--------++The following commands are supported.++``call`` *entry* *o1* ... *oN* *i1* ... *oM*+............................................++Call the given entry point with input from the variables *i1* to *oM*.+The results are stored in *o1* to *oN*, which must not already exist.++``restore`` *file* *v1* *t1* ... *vN* *tN*+..........................................++Load *N* values from *file* and store them in the variables *v1* to+*vN* of types *t1* to *tN*, which must not already exist.++``store`` *file* *v1* ... *vN*+..............................++Store the *N* values in variables *v1* to *vN* in *file*.++``free`` *v1* ... *vN*+......................++Delete the given variables.++``inputs`` *entry*+..................++Print the types of inputs accepted by the given entry point, one per+line.++``outputs`` *entry*+...................++Print the types of outputs produced by the given entry point, one per+line.++``clear``+.........++Clear all internal caches and counters maintained by the Futhark+context.  Corresponds to :c:func:`futhark_context_clear_caches`.++``pause_profiling``+...................++Corresponds to :c:func:`futhark_context_pause_profiling`.++``unpause_profiling``+.....................++Corresponds to :c:func:`futhark_context_unpause_profiling`.++``report``+..........++Corresponds to :c:func:`futhark_context_report`.

@@ -13,11 +13,13 @@ 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.+There are three main ways of compiling a Futhark program: to an+ordinary executable (by using ``--executable``, which is the default),+to a *server executable* (``--server``), and to a library+(``--library``).  Plain executables can be run immediately, but are+useful mostly for testing and benchmarking.  Server executables are+discussed in :ref:`server-protocol`. Libraries can be called from+non-Futhark code.  .. _executable: @@ -78,6 +80,19 @@      Print help text to standard output and exit. +  ``-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.++Non-Server Executable Options+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The following options are only supported on non-server executables,+because they make no sense in a server context.+   ``-t FILE``      Print the time taken to execute the program to the indicated file,@@ -92,13 +107,6 @@     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`` 

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           futhark-version:        0.18.5+version:        0.18.6 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -59,6 +59,7 @@       Futhark.Analysis.HORep.MapNest       Futhark.Analysis.HORep.SOAC       Futhark.Analysis.Metrics+      Futhark.Analysis.Metrics.Type       Futhark.Analysis.PrimExp       Futhark.Analysis.PrimExp.Convert       Futhark.Analysis.PrimExp.Generalize@@ -78,6 +79,7 @@       Futhark.CLI.Dataset       Futhark.CLI.Dev       Futhark.CLI.Doc+      Futhark.CLI.Literate       Futhark.CLI.Misc       Futhark.CLI.Multicore       Futhark.CLI.OpenCL@@ -94,6 +96,7 @@       Futhark.CodeGen.Backends.COpenCL.Boilerplate       Futhark.CodeGen.Backends.GenericC       Futhark.CodeGen.Backends.GenericC.CLI+      Futhark.CodeGen.Backends.GenericC.Server       Futhark.CodeGen.Backends.GenericC.Options       Futhark.CodeGen.Backends.GenericPython       Futhark.CodeGen.Backends.GenericPython.AST@@ -231,8 +234,11 @@       Futhark.Pkg.Info       Futhark.Pkg.Solve       Futhark.Pkg.Types+      Futhark.Script+      Futhark.Server       Futhark.Test       Futhark.Test.Values+      Futhark.Test.Values.Parser       Futhark.Tools       Futhark.Transform.CopyPropagate       Futhark.Transform.FirstOrderTransform@@ -287,6 +293,7 @@     , binary >=0.8.3     , blaze-html >=0.9.0.1     , bytestring >=0.10.8+    , bytestring-to-vector >=0.3.0.1     , containers >=0.6.2.1     , directory >=1.3.0.0     , directory-tree >=0.12.1@@ -299,7 +306,7 @@     , language-c-quote >=0.12     , mainland-pretty >=0.6.1     , cmark-gfm >=0.2.1-    , megaparsec >=8.0.0+    , megaparsec >=9.0.0     , mtl >=2.2.1     , neat-interpolation >=0.3     , parallel >=3.2.1.0

@@ -44,7 +44,10 @@   val >=: t -> t -> bool   val !=: t -> t -> bool -  val negate: t-> t+  -- | Arithmetic negation (use `!` for bitwise negation).+  val neg: t -> t+  -- | Deprecated alias for `neg`.+  val negate: t -> t   val max: t -> t -> t   val min: t -> t -> t @@ -278,14 +281,15 @@   let sgn (x: i8) = intrinsics.ssignum8 x   let abs (x: i8) = intrinsics.abs8 x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 8i32   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))@@ -350,14 +354,15 @@   let sgn (x: i16) = intrinsics.ssignum16 x   let abs (x: i16) = intrinsics.abs16 x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 16i32   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))@@ -425,14 +430,15 @@   let sgn (x: i32) = intrinsics.ssignum32 x   let abs (x: i32) = intrinsics.abs32 x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   let max (x: t) (y: t) = intrinsics.smax32 (x, y)   let min (x: t) (y: t) = intrinsics.smin32 (x, y) -  let highest = 2147483647+  let highest = 2147483647i32   let lowest = highest + 1 -  let num_bits = 32+  let num_bits = 32i32   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))@@ -500,14 +506,15 @@   let sgn (x: i64) = intrinsics.ssignum64 x   let abs (x: i64) = intrinsics.abs64 x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 64i32   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))@@ -575,14 +582,15 @@   let sgn (x: u8) = unsign (intrinsics.usignum8 (sign x))   let abs (x: u8) = x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 8i32   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))@@ -650,14 +658,15 @@   let sgn (x: u16) = unsign (intrinsics.usignum16 (sign x))   let abs (x: u16) = x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 16i32   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))@@ -728,11 +737,12 @@   let highest = 4294967295u32   let lowest = highest + 1u32 -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 32i32   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))@@ -800,14 +810,15 @@   let sgn (x: u64) = unsign (intrinsics.usignum64 (sign x))   let abs (x: u64) = x -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   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 num_bits = 64i32   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))@@ -863,7 +874,8 @@   let (x: f64) >= (y: f64) = intrinsics.le64 (y, x)   let (x: f64) != (y: f64) = intrinsics.! (x == y) -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   let max (x: t) (y: t) = intrinsics.fmax64 (x, y)   let min (x: t) (y: t) = intrinsics.fmin64 (x, y) @@ -907,7 +919,7 @@   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 num_bits = 64i32   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) @@ -970,7 +982,8 @@   let (x: f32) >= (y: f32) = intrinsics.le32 (y, x)   let (x: f32) != (y: f32) = intrinsics.! (x == y) -  let negate (x: t) = -x+  let neg (x: t) = -x+  let negate = neg   let max (x: t) (y: t) = intrinsics.fmax32 (x, y)   let min (x: t) (y: t) = intrinsics.fmin32 (x, y) @@ -1014,7 +1027,7 @@   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 num_bits = 32i32   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) 

@@ -495,7 +495,7 @@     struct profiling_record record = ctx->profiling_records[i];      float ms;-    if ((err = cudaEventElapsedTime(&ms, record.events[0], record.events[1])) != CUDA_SUCCESS) {+    if ((err = cudaEventElapsedTime(&ms, record.events[0], record.events[1])) != cudaSuccess) {       return err;     } @@ -503,10 +503,10 @@     *record.runs += 1;     *record.runtime += ms*1000; -    if ((err = cudaEventDestroy(record.events[0])) != CUDA_SUCCESS) {+    if ((err = cudaEventDestroy(record.events[0])) != cudaSuccess) {       return err;     }-    if ((err = cudaEventDestroy(record.events[1])) != CUDA_SUCCESS) {+    if ((err = cudaEventDestroy(record.events[1])) != cudaSuccess) {       return err;     } @@ -515,7 +515,7 @@    ctx->profiling_records_used = 0; -  return CUDA_SUCCESS;+  return cudaSuccess; }  // Returns pointer to two events.

@@ -853,9 +853,6 @@   struct worker *worker = worker_local;    int err = 0;-  if (task->iterations == 0) {-    return err;-  }    // How much sequential work was performed by the task   int64_t task_timer = 0;

@@ -0,0 +1,630 @@+// Start of server.h.++// Forward declarations of things that we technically don't know until+// the application header file is included, but which we need.+struct futhark_context;+char *futhark_context_get_error(struct futhark_context *ctx);+int futhark_context_sync(struct futhark_context *ctx);+int futhark_context_clear_caches(struct futhark_context *ctx);++typedef int (*restore_fn)(const void*, FILE *, struct futhark_context*, void*);+typedef void (*store_fn)(const void*, FILE *, struct futhark_context*, void*);+typedef int (*free_fn)(const void*, struct futhark_context*, void*);++struct type {+  const char *name;+  restore_fn restore;+  store_fn store;+  free_fn free;+  const void *aux;+};++int free_scalar(const void *aux, struct futhark_context *ctx, void *p) {+  (void)aux;+  (void)ctx;+  (void)p;+  // Nothing to do.+  return 0;+}++#define DEF_SCALAR_TYPE(T)                                              \+  int restore_##T(const void *aux, FILE *f,                             \+                  struct futhark_context *ctx, void *p) {               \+    (void)aux;                                                          \+    (void)ctx;                                                          \+    return read_scalar(f, &T##_info, p);                                \+  }                                                                     \+                                                                        \+  void store_##T(const void *aux, FILE *f,                              \+                 struct futhark_context *ctx, void *p) {                \+    (void)aux;                                                          \+    (void)ctx;                                                          \+    write_scalar(f, 1, &T##_info, p);                                   \+  }                                                                     \+                                                                        \+  struct type type_##T =                                                \+    { .name = #T,                                                       \+      .restore = restore_##T,                                           \+      .store = store_##T,                                               \+      .free = free_scalar                                               \+    }                                                                   \++DEF_SCALAR_TYPE(i8);+DEF_SCALAR_TYPE(i16);+DEF_SCALAR_TYPE(i32);+DEF_SCALAR_TYPE(i64);+DEF_SCALAR_TYPE(u8);+DEF_SCALAR_TYPE(u16);+DEF_SCALAR_TYPE(u32);+DEF_SCALAR_TYPE(u64);+DEF_SCALAR_TYPE(f32);+DEF_SCALAR_TYPE(f64);+DEF_SCALAR_TYPE(bool);++struct value {+  struct type *type;+  union {+    void *v_ptr;+    int8_t  v_i8;+    int16_t v_i16;+    int32_t v_i32;+    int64_t v_i64;++    uint8_t  v_u8;+    uint16_t v_u16;+    uint32_t v_u32;+    uint64_t v_u64;++    float v_f32;+    double v_f64;++    bool v_bool;+  } value;+};++void* value_ptr(struct value *v) {+  if (v->type == &type_i8) {+    return &v->value.v_i8;+  }+  if (v->type == &type_i16) {+    return &v->value.v_i16;+  }+  if (v->type == &type_i32) {+    return &v->value.v_i32;+  }+  if (v->type == &type_i64) {+    return &v->value.v_i64;+  }+  if (v->type == &type_u8) {+    return &v->value.v_u8;+  }+  if (v->type == &type_u16) {+    return &v->value.v_u16;+  }+  if (v->type == &type_u32) {+    return &v->value.v_u32;+  }+  if (v->type == &type_u64) {+    return &v->value.v_u64;+  }+  if (v->type == &type_f32) {+    return &v->value.v_f32;+  }+  if (v->type == &type_f64) {+    return &v->value.v_f64;+  }+  if (v->type == &type_bool) {+    return &v->value.v_bool;+  }+  return &v->value.v_ptr;+}++struct variable {+  // NULL name indicates free slot.  Name is owned by this struct.+  char *name;+  struct value value;+};++typedef int (*entry_point_fn)(struct futhark_context*, void**, void**);++struct entry_point {+  const char *name;+  entry_point_fn f;+  struct type **out_types;+  struct type **in_types;+};++int entry_num_ins(struct entry_point *e) {+  int count = 0;+  while (e->in_types[count]) {+    count++;+  }+  return count;+}++int entry_num_outs(struct entry_point *e) {+  int count = 0;+  while (e->out_types[count]) {+    count++;+  }+  return count;+}++struct futhark_prog {+  // Last entry point identified by NULL name.+  struct entry_point *entry_points;+  // Last type identified by NULL name.+  struct type **types;+};++struct server_state {+  struct futhark_prog prog;+  struct futhark_context *ctx;+  int variables_capacity;+  struct variable *variables;+};++struct variable* get_variable(struct server_state *s,+                              const char *name) {+  for (int i = 0; i < s->variables_capacity; i++) {+    if (s->variables[i].name != NULL &&+        strcmp(s->variables[i].name, name) == 0) {+      return &s->variables[i];+    }+  }++  return NULL;+}++struct variable* create_variable(struct server_state *s,+                                 const char *name,+                                 struct type *type) {+  int found = -1;+  for (int i = 0; i < s->variables_capacity; i++) {+    if (found == -1 && s->variables[i].name == NULL) {+      found = i;+    } else if (s->variables[i].name != NULL &&+               strcmp(s->variables[i].name, name) == 0) {+      return NULL;+    }+  }++  if (found != -1) {+    // Found a free spot.+    s->variables[found].name = strdup(name);+    s->variables[found].value.type = type;+    return &s->variables[found];+  }++  // Need to grow the buffer.+  found = s->variables_capacity;+  s->variables_capacity *= 2;+  s->variables = realloc(s->variables,+                         s->variables_capacity * sizeof(struct variable));++  s->variables[found].name = strdup(name);+  s->variables[found].value.type = type;++  for (int i = found+1; i < s->variables_capacity; i++) {+    s->variables[i].name = NULL;+  }++  return &s->variables[found];+}++void drop_variable(struct variable *v) {+  free(v->name);+  v->name = NULL;+}++int arg_exists(const char *args[], int i) {+  return args[i] != NULL;+}++const char* get_arg(const char *args[], int i) {+  if (!arg_exists(args, i)) {+    futhark_panic(1, "Insufficient command args.\n");+  }+  return args[i];+}++struct type* get_type(struct server_state *s, const char *name) {+  for (int i = 0; s->prog.types[i]; i++) {+    if (strcmp(s->prog.types[i]->name, name) == 0) {+      return s->prog.types[i];+    }+  }++  futhark_panic(1, "Unknown type %s\n", name);+  return NULL;+}++struct entry_point* get_entry_point(struct server_state *s, const char *name) {+  for (int i = 0; s->prog.entry_points[i].name; i++) {+    if (strcmp(s->prog.entry_points[i].name, name) == 0) {+      return &s->prog.entry_points[i];+    }+  }++  return NULL;+}++// Print the command-done marker, indicating that we are ready for+// more input.+void ok() {+  printf("%%%%%% OK\n");+  fflush(stdout);+}++// Print the failure marker.  Output is now an error message until the+// next ok().+void failure() {+  printf("%%%%%% FAILURE\n");+}++void error_check(struct server_state *s, int err) {+  if (err != 0) {+    failure();+    char *error = futhark_context_get_error(s->ctx);+    puts(error);+    free(error);+  }+}++void cmd_call(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);++  struct entry_point *e = get_entry_point(s, name);++  if (e == NULL) {+    failure();+    printf("Unknown entry point: %s\n", name);+    return;+  }++  int num_outs = entry_num_outs(e);+  int num_ins = entry_num_ins(e);+  void* outs[num_outs];+  void* ins[num_ins];++  for (int i = 0; i < num_ins; i++) {+    const char *in_name = get_arg(args, 1+num_outs+i);+    struct variable *v = get_variable(s, in_name);+    if (v == NULL) {+      failure();+      printf("Unknown variable: %s\n", in_name);+      return;+    }+    if (v->value.type != e->in_types[i]) {+      failure();+      printf("Wrong input type.  Expected %s, got %s.\n",+             e->in_types[i]->name, v->value.type->name);+      return;+    }+    ins[i] = value_ptr(&v->value);+  }++  for (int i = 0; i < num_outs; i++) {+    const char *out_name = get_arg(args, 1+i);+    struct variable *v = create_variable(s, out_name, e->out_types[i]);+    if (v == NULL) {+      failure();+      printf("Variable already exists: %s\n", out_name);+      return;+    }+    outs[i] = value_ptr(&v->value);+  }++  int64_t t_start = get_wall_time();+  int err = e->f(s->ctx, outs, ins);+  err |= futhark_context_sync(s->ctx);+  int64_t t_end = get_wall_time();+  long long int elapsed_usec = t_end - t_start;+  printf("runtime: %lld\n", elapsed_usec);++  error_check(s, err);+  if (err != 0) {+    // Need to uncreate the output variables, which would otherwise be left+    // in an uninitialised state.+    for (int i = 0; i < num_outs; i++) {+      const char *out_name = get_arg(args, 1+i);+      struct variable *v = get_variable(s, out_name);+      if (v) {+        drop_variable(v);+      }+    }+  }+}++void cmd_restore(struct server_state *s, const char *args[]) {+  const char *fname = get_arg(args, 0);++  FILE *f = fopen(fname, "rb");+  if (f == NULL) {+    failure();+    printf("Failed to open %s: %s\n", fname, strerror(errno));+  } else {+    int values = 0;+    for (int i = 1; arg_exists(args, i); i+=2, values++) {+      const char *vname = get_arg(args, i);+      const char *type = get_arg(args, i+1);++      struct type *t = get_type(s, type);+      struct variable *v = create_variable(s, vname, t);++      if (v == NULL) {+        failure();+        printf("Variable already exists: %s\n", vname);+        return;+      }++      if (t->restore(t->aux, f, s->ctx, value_ptr(&v->value)) != 0) {+        failure();+        printf("Failed to restore variable %s.\n"+               "Possibly malformed data in %s (errno: %s)\n",+               vname, fname, strerror(errno));+        drop_variable(v);+        break;+      }+    }++    if (end_of_input(f) != 0) {+      failure();+      printf("Expected EOF after reading %d values from %s\n",+             values, fname);+    }++    fclose(f);+  }++  int err = futhark_context_sync(s->ctx);+  error_check(s, err);+}++void cmd_store(struct server_state *s, const char *args[]) {+  const char *fname = get_arg(args, 0);++  FILE *f = fopen(fname, "wb");+  if (f == NULL) {+    failure();+    printf("Failed to open %s: %s\n", fname, strerror(errno));+  } else {+    for (int i = 1; arg_exists(args, i); i++) {+      const char *vname = get_arg(args, i);+      struct variable *v = get_variable(s, vname);++      if (v == NULL) {+        failure();+        printf("Unknown variable: %s\n", vname);+        return;+      }++      struct type *t = v->value.type;+      t->store(t->aux, f, s->ctx, value_ptr(&v->value));+    }+    fclose(f);+  }+}++void cmd_free(struct server_state *s, const char *args[]) {+  for (int i = 0; arg_exists(args, i); i++) {+    const char *name = get_arg(args, i);+    struct variable *v = get_variable(s, name);++    if (v == NULL) {+      failure();+      printf("Unknown variable: %s\n", name);+      return;+    }++    struct type *t = v->value.type;++    int err = t->free(t->aux, s->ctx, value_ptr(&v->value));+    error_check(s, err);+    drop_variable(v);+  }+}++void cmd_inputs(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);+  struct entry_point *e = get_entry_point(s, name);++  if (e == NULL) {+    failure();+    printf("Unknown entry point: %s\n", name);+    return;+  }++  int num_ins = entry_num_ins(e);+  for (int i = 0; i < num_ins; i++) {+    puts(e->in_types[i]->name);+  }+}++void cmd_outputs(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);+  struct entry_point *e = get_entry_point(s, name);++  if (e == NULL) {+    failure();+    printf("Unknown entry point: %s\n", name);+    return;+  }++  int num_outs = entry_num_outs(e);+  for (int i = 0; i < num_outs; i++) {+    puts(e->out_types[i]->name);+  }+}++void cmd_clear(struct server_state *s, const char *args[]) {+  (void)args;+  int err = 0;+  for (int i = 0; i < s->variables_capacity; i++) {+    struct variable *v = &s->variables[i];+    if (v->name != NULL) {+      err |= v->value.type->free(v->value.type->aux, s->ctx, value_ptr(&v->value));+      drop_variable(v);+    }+  }+  err |= futhark_context_clear_caches(s->ctx);+  error_check(s, err);+}++void cmd_pause_profiling(struct server_state *s, const char *args[]) {+  (void)args;+  futhark_context_pause_profiling(s->ctx);+}++void cmd_unpause_profiling(struct server_state *s, const char *args[]) {+  (void)args;+  futhark_context_unpause_profiling(s->ctx);+}++void cmd_report(struct server_state *s, const char *args[]) {+  (void)args;+  char *report = futhark_context_report(s->ctx);+  puts(report);+  free(report);+}++void process_line(struct server_state *s, char *line) {+  int max_num_tokens = 100;+  const char* tokens[max_num_tokens];+  int num_tokens = 0;+  char *saveptr;++  char *tmp = line;+  while ((tokens[num_tokens] = strtok_r(tmp, " \n", &saveptr)) != NULL) {+    num_tokens++;+    if (num_tokens == max_num_tokens) {+      futhark_panic(1, "Line too long.\n");+    }+    tmp = NULL;+  }++  const char *command = tokens[0];++  if (command == NULL) {+    failure();+    printf("Empty line\n");+  } else if (strcmp(command, "call") == 0) {+    cmd_call(s, tokens+1);+  } else if (strcmp(command, "restore") == 0) {+    cmd_restore(s, tokens+1);+  } else if (strcmp(command, "store") == 0) {+    cmd_store(s, tokens+1);+  } else if (strcmp(command, "free") == 0) {+    cmd_free(s, tokens+1);+  } else if (strcmp(command, "inputs") == 0) {+    cmd_inputs(s, tokens+1);+  } else if (strcmp(command, "outputs") == 0) {+    cmd_outputs(s, tokens+1);+  } else if (strcmp(command, "clear") == 0) {+    cmd_clear(s, tokens+1);+  } else if (strcmp(command, "pause_profiling") == 0) {+    cmd_pause_profiling(s, tokens+1);+  } else if (strcmp(command, "unpause_profiling") == 0) {+    cmd_unpause_profiling(s, tokens+1);+  } else if (strcmp(command, "report") == 0) {+    cmd_report(s, tokens+1);+  } else {+    futhark_panic(1, "Unknown command: %s\n", command);+  }+  ok();+}++void run_server(struct futhark_prog *prog, struct futhark_context *ctx) {+  char *line = NULL;+  size_t buflen = 0;+  ssize_t linelen;++  struct server_state s = {+    .ctx = ctx,+    .variables_capacity = 100,+    .prog = *prog+  };++  s.variables = malloc(s.variables_capacity * sizeof(struct variable));++  for (int i = 0; i < s.variables_capacity; i++) {+    s.variables[i].name = NULL;+  }++  while ((linelen = getline(&line, &buflen, stdin)) > 0) {+    process_line(&s, line);+  }++  free(line);+}++// The aux struct lets us write generic method implementations without+// code duplication.++typedef void* (*array_new_fn)(struct futhark_context *, const void*, const int64_t*);+typedef const int64_t* (*array_shape_fn)(struct futhark_context*, void*);+typedef int (*array_values_fn)(struct futhark_context*, void*, void*);+typedef int (*array_free_fn)(struct futhark_context*, void*);++struct array_aux {+  int rank;+  const struct primtype_info_t* info;+  const char *name;+  array_new_fn new;+  array_shape_fn shape;+  array_values_fn values;+  array_free_fn free;+};++int restore_array(const struct array_aux *aux, FILE *f,+                  struct futhark_context *ctx, void *p) {+  void *data = NULL;+  int64_t shape[aux->rank];+  if (read_array(f, aux->info, &data, shape, aux->rank) != 0) {+    return 1;+  }++  void *arr = aux->new(ctx, data, shape);+  if (arr == NULL) {+    return 1;+  }++  *(void**)p = arr;+  free(data);+  return 0;+}++void store_array(const struct array_aux *aux, FILE *f,+                 struct futhark_context *ctx, void *p) {+  void *arr = *(void**)p;+  const int64_t *shape = aux->shape(ctx, arr);+  int64_t size = sizeof(aux->info->size);+  for (int i = 0; i < aux->rank; i++) {+    size *= shape[i];+  }+  int32_t *data = malloc(size);+  assert(aux->values(ctx, arr, data) == 0);+  assert(futhark_context_sync(ctx) == 0);+  assert(write_array(f, 1, aux->info, data, shape, aux->rank) == 0);+  free(data);+}++int free_array(const struct array_aux *aux,+                struct futhark_context *ctx, void *p) {+  void *arr = *(void**)p;+  return aux->free(ctx, arr);+}++typedef int (*opaque_free_fn)(struct futhark_context*, void*);++struct opaque_aux {+  opaque_free_fn free;+};++int free_opaque(const struct opaque_aux *aux,+                 struct futhark_context *ctx, void *p) {+  void *obj = *(void**)p;+  return aux->free(ctx, obj);+}++// End of server.h.

@@ -0,0 +1,165 @@+# Start of server.py++import sys+import time++class Server:+    def __init__(self, ctx):+        self._ctx = ctx+        self._vars = {}++    class Failure(BaseException):+        def __init__(self, msg):+            self.msg = msg++    def _get_arg(self, args, i):+        if i < len(args):+            return args[i]+        else:+            raise self.Failure('Insufficient command args')++    def _get_entry_point(self, entry):+        if entry in self._ctx.entry_points:+            return self._ctx.entry_points[entry]+        else:+            raise self.Failure('Unknown entry point: %s' % entry)++    def _check_var(self, vname):+        if not vname in self._vars:+            raise self.Failure('Unknown variable: %s' % vname)++    def _get_var(self, vname):+        self._check_var(vname)+        return self._vars[vname]++    def _cmd_inputs(self, args):+        entry = self._get_arg(args, 0)+        for t in self._get_entry_point(entry)[0]:+            print(t)++    def _cmd_outputs(self, args):+        entry = self._get_arg(args, 0)+        for t in self._get_entry_point(entry)[1]:+            print(t)++    def _cmd_dummy(self, args):+        pass++    def _cmd_free(self, args):+        for vname in args:+            self._check_var(vname)+            del self._vars[vname]++    def _cmd_call(self, args):+        entry = self._get_entry_point(self._get_arg(args, 0))+        num_ins = len(entry[0])+        num_outs = len(entry[1])++        if len(args) != 1 + num_outs + num_ins:+            raise self.Failure('Invalid argument count, expected %d')++        out_vnames = args[1:num_outs+1]++        for out_vname in out_vnames:+            if out_vname in self._vars:+                raise self.Failure('Variable already exists: %s' % out_vname)++        in_vnames = args[1+num_outs:]+        ins = [ self._get_var(in_vname) for in_vname in in_vnames ]++        try:+            (runtime, vals) = getattr(self._ctx, args[0])(*ins)+        except Exception as e:+            raise self.Failure(str(e))++        print('runtime: %d' % runtime)++        if num_outs == 1:+            self._vars[out_vnames[0]] = vals+        else:+            for (out_vname, val) in zip(out_vnames, vals):+                self._vars[out_vname] = val++    def _cmd_store(self, args):+        fname = self._get_arg(args, 0)++        with open(fname, 'wb') as f:+            for i in range(1, len(args)):+                vname = args[i]+                value = self._get_var(vname)+                # In case we are using the PyOpenCL backend, we first+                # need to convert OpenCL arrays to ordinary NumPy+                # arrays.  We do this in a nasty way.+                if isinstance(value, np.number) or isinstance(value, np.bool) or isinstance(value, np.bool_) or isinstance(value, np.ndarray):+                    # Ordinary NumPy value.+                    f.write(construct_binary_value(self._vars[vname]))+                else:+                    # Assuming PyOpenCL array.+                    f.write(construct_binary_value(self._vars[vname].get()))++    def _cmd_restore(self, args):+        if len(args) % 2 == 0:+            raise self.Failure('Invalid argument count')++        fname = args[0]+        args = args[1:]++        with open(fname, 'rb') as f:+            reader = ReaderInput(f)+            while args != []:+                vname = args[0]+                typename = args[1]+                args = args[2:]++                if vname in self._vars:+                    raise self.Failure('Variable already exists: %s' % vname)++                try:+                    self._vars[vname] = read_value(typename, reader)+                except ValueError:+                    raise self.Failure('Failed to restore variable %s.\n'+                                       'Possibly malformed data in %s.\n'+                                       % (vname, fname))++            skip_spaces(reader)+            if reader.get_char() != b'':+                raise self.Failure('Expected EOF after reading values')++    _commands = { 'inputs': _cmd_inputs,+                  'outputs': _cmd_outputs,+                  'call': _cmd_call,+                  'restore': _cmd_restore,+                  'store': _cmd_store,+                  'free': _cmd_free,+                  'clear': _cmd_dummy,+                  'pause_profiling': _cmd_dummy,+                  'unpause_profiling': _cmd_dummy,+                  'report': _cmd_dummy+                 }++    def _process_line(self, line):+        words = line.split()+        if words == []:+            raise self.Failure('Empty line')+        else:+            cmd = words[0]+            args = words[1:]+            if cmd in self._commands:+                self._commands[cmd](self, args)+            else:+                raise self.Failure('Unknown command: %s' % cmd)++    def run(self):+        while True:+            line = sys.stdin.readline()+            if line == '':+                return+            try:+                self._process_line(line)+            except self.Failure as e:+                print('%%% FAILURE')+                print(e.msg)+            print('%%% OK', flush=True)+++# End of server.py

@@ -77,6 +77,7 @@       actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenKernels.compileProgOpenCL     } +-- | Convert the program to CPU multicore ImpCode and print it to stdout. multicoreImpCodeGenAction :: Action MCMem multicoreImpCodeGenAction =   Action@@ -160,6 +161,9 @@         ToExecutable -> do           liftIO $ writeFile cpath $ SequentialC.asExecutable cprog           runCC cpath outpath ["-O3", "-std=c99"] ["-lm"]+        ToServer -> do+          liftIO $ writeFile cpath $ SequentialC.asServer cprog+          runCC cpath outpath ["-O3", "-std=c99"] ["-lm"]  -- | The @futhark opencl@ action. compileOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem@@ -190,6 +194,9 @@         ToExecutable -> do           liftIO $ writeFile cpath $ COpenCL.asExecutable cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)+        ToServer -> do+          liftIO $ writeFile cpath $ COpenCL.asServer cprog+          runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)  -- | The @futhark cuda@ action. compileCUDAAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem@@ -217,6 +224,9 @@         ToExecutable -> do           liftIO $ writeFile cpath $ CCUDA.asExecutable cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)+        ToServer -> do+          liftIO $ writeFile cpath $ CCUDA.asServer cprog+          runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)  -- | The @futhark multicore@ action. compileMulticoreAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem@@ -239,4 +249,7 @@           liftIO $ writeFile cpath impl         ToExecutable -> do           liftIO $ writeFile cpath $ MulticoreC.asExecutable cprog+          runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"]+        ToServer -> do+          liftIO $ writeFile cpath $ MulticoreC.asServer cprog           runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"]

@@ -24,25 +24,8 @@ import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T+import Futhark.Analysis.Metrics.Type import Futhark.IR---- | AST metrics are simply a collection from identifiable node names--- to the number of times that node appears.-newtype AstMetrics = AstMetrics (M.Map Text Int)--instance Show AstMetrics where-  show (AstMetrics m) = unlines $ map metric $ M.toList m-    where-      metric (k, v) = pretty k ++ " " ++ pretty v--instance Read AstMetrics where-  readsPrec _ s =-    maybe [] success $ mapM onLine $ lines s-    where-      onLine l = case words l of-        [k, x] | [(n, "")] <- reads x -> Just (T.pack k, n)-        _ -> Nothing-      success m = [(AstMetrics $ M.fromList m, "")]  -- | Compute the metrics for some operation. class OpMetrics op where

@@ -0,0 +1,26 @@+-- | The data type definition for "Futhark.Analysis.Metrics", factored+-- out to simplify the module import hierarchies when working on the+-- test modules.+module Futhark.Analysis.Metrics.Type (AstMetrics (..)) where++import qualified Data.Map.Strict as M+import Data.Text (Text)+import qualified Data.Text as T++-- | AST metrics are simply a collection from identifiable node names+-- to the number of times that node appears.+newtype AstMetrics = AstMetrics (M.Map Text Int)++instance Show AstMetrics where+  show (AstMetrics m) = unlines $ map metric $ M.toList m+    where+      metric (k, v) = T.unpack k ++ " " ++ show v++instance Read AstMetrics where+  readsPrec _ s =+    maybe [] success $ mapM onLine $ lines s+    where+      onLine l = case words l of+        [k, x] | [(n, "")] <- reads x -> Just (T.pack k, n)+        _ -> Nothing+      success m = [(AstMetrics $ M.fromList m, "")]

@@ -147,19 +147,19 @@ instance FreeIn v => FreeIn (TPrimExp t v) where   freeIn' = freeIn' . untyped --- | This expression is of type 'Int8'.+-- | This expression is of type t'Int8'. isInt8 :: PrimExp v -> TPrimExp Int8 v isInt8 = TPrimExp --- | This expression is of type 'Int16'.+-- | This expression is of type t'Int16'. isInt16 :: PrimExp v -> TPrimExp Int16 v isInt16 = TPrimExp --- | This expression is of type 'Int32'.+-- | This expression is of type t'Int32'. isInt32 :: PrimExp v -> TPrimExp Int32 v isInt32 = TPrimExp --- | This expression is of type 'Int64'.+-- | This expression is of type t'Int64'. isInt64 :: PrimExp v -> TPrimExp Int64 v isInt64 = TPrimExp @@ -167,11 +167,11 @@ isBool :: PrimExp v -> TPrimExp Bool v isBool = TPrimExp --- | This expression is of type 'Float'.+-- | This expression is of type t'Float'. isF32 :: PrimExp v -> TPrimExp Float v isF32 = TPrimExp --- | This expression is of type 'Double'.+-- | This expression is of type t'Double'. isF64 :: PrimExp v -> TPrimExp Double v isF64 = TPrimExp 

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}  -- | Facilities for changing the lore of some fragment, with no -- context.  We call this "rephrasing", for no deep reason.

@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}  module Futhark.Analysis.SymbolTable   ( SymbolTable (bindings, loopDepth, availableAtClosestLoop, simplifyMemory),

@@ -7,6 +7,7 @@   ( RunResult (..),     DataResult (..),     BenchResult (..),+    Result (..),     encodeBenchResults,     decodeBenchResults,     binaryName,@@ -18,21 +19,18 @@ where  import Control.Applicative-import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad.Except import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import Data.Maybe import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.IO as T+import Futhark.Server import Futhark.Test import System.Exit import System.FilePath-import System.IO-import System.IO.Error-import System.IO.Temp (withSystemTempFile) import System.Process.ByteString (readProcessWithExitCode) import System.Timeout (timeout) @@ -40,10 +38,17 @@ newtype RunResult = RunResult {runMicroseconds :: Int}   deriving (Eq, Show) --- | The results for a single named dataset is either an error--- message, or runtime measurements along the stderr that was+data Result = Result+  { runResults :: [RunResult],+    memoryMap :: M.Map T.Text Int,+    stdErr :: T.Text+  }+  deriving (Eq, Show)++-- | The results for a single named dataset is either an error message, or+-- runtime measurements, the number of bytes used, and the stderr that was -- produced.-data DataResult = DataResult String (Either T.Text ([RunResult], T.Text))+data DataResult = DataResult String (Either T.Text Result)   deriving (Eq, Show)  -- | The results for all datasets for some benchmark program.@@ -54,6 +59,12 @@  newtype BenchResults = BenchResults {unBenchResults :: [BenchResult]} +instance JSON.ToJSON Result where+  toJSON (Result runres memmap err) = JSON.toJSON (runres, memmap, err)++instance JSON.FromJSON Result where+  parseJSON = fmap (\(runres, memmap, err) -> Result runres memmap err) . JSON.parseJSON+ instance JSON.ToJSON RunResult where   toJSON = JSON.toJSON . runMicroseconds @@ -74,15 +85,16 @@         DataResult (T.unpack k)           <$> ((Right <$> success v) <|> (Left <$> JSON.parseJSON v))       success = JSON.withObject "result" $ \o ->-        (,) <$> o JSON..: "runtimes" <*> o JSON..: "stderr"+        Result <$> o JSON..: "runtimes" <*> o JSON..: "bytes" <*> o JSON..: "stderr"  dataResultJSON :: DataResult -> (T.Text, JSON.Value) dataResultJSON (DataResult desc (Left err)) =   (T.pack desc, JSON.toJSON err)-dataResultJSON (DataResult desc (Right (runtimes, progerr))) =+dataResultJSON (DataResult desc (Right (Result runtimes bytes progerr))) =   ( T.pack desc,     JSON.object       [ ("runtimes", JSON.toJSON $ map runMicroseconds runtimes),+        ("bytes", JSON.toJSON bytes),         ("stderr", JSON.toJSON progerr)       ]   )@@ -117,67 +129,9 @@  --- Running benchmarks -readRuntime :: T.Text -> Maybe Int-readRuntime s = case reads $ T.unpack s of-  [(runtime, _)] -> Just runtime-  _ -> Nothing--didNotFail :: FilePath -> ExitCode -> T.Text -> ExceptT T.Text IO ()-didNotFail _ ExitSuccess _ =-  return ()-didNotFail program (ExitFailure code) stderr_s =-  throwError $-    T.pack $-      program ++ " failed with error code " ++ show code-        ++ " and output:\n"-        ++ T.unpack stderr_s--compareResult ::-  (MonadError T.Text m, MonadIO m) =>-  FilePath ->-  (SBS.ByteString, [Value]) ->-  (SBS.ByteString, [Value]) ->-  m ()-compareResult program (expected_bs, expected_vs) (actual_bs, actual_vs) =-  case compareValues1 actual_vs expected_vs of-    Just mismatch -> do-      let actualf = program `replaceExtension` "actual"-          expectedf = program `replaceExtension` "expected"-      liftIO $ SBS.writeFile actualf actual_bs-      liftIO $ SBS.writeFile expectedf expected_bs-      throwError $-        T.pack actualf <> " and " <> T.pack expectedf-          <> " do not match:\n"-          <> T.pack (show mismatch)-    Nothing ->-      return ()--runResult ::-  (MonadError T.Text m, MonadIO m) =>-  FilePath ->-  ExitCode ->-  SBS.ByteString ->-  SBS.ByteString ->-  m (SBS.ByteString, [Value])-runResult program ExitSuccess stdout_s _ =-  case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of-    Left e -> do-      let actualf = program `replaceExtension` "actual"-      liftIO $ SBS.writeFile actualf stdout_s-      throwError $ T.pack $ show e <> "\n(See " <> actualf <> ")"-    Right vs -> return (stdout_s, vs)-runResult program (ExitFailure code) _ stderr_s =-  throwError $-    T.pack $-      binaryName program ++ " failed with error code " ++ show code-        ++ " and output:\n"-        ++ T.unpack (T.decodeUtf8 stderr_s)- -- | How to run a benchmark. data RunOptions = RunOptions-  { runRunner :: String,-    runRuns :: Int,-    runExtraOptions :: [String],+  { runRuns :: Int,     runTimeout :: Int,     runVerbose :: Int,     -- | Invoked for every runtime measured during the run.  Can be@@ -185,33 +139,15 @@     runResultAction :: Maybe (Int -> IO ())   } --- | Like @tail -f@, but running an arbitrary IO action per line.-follow :: (String -> IO ()) -> FilePath -> IO ()-follow f fname = go 0-  where-    go i = do-      i' <- withFile fname ReadMode $ \h -> do-        hSeek h AbsoluteSeek i-        goH h i-      go i'--    goH h i = do-      res <- tryIOError $ hGetLine h-      case res of-        Left e-          | isEOFError e -> do-            threadDelay followDelayMicroseconds-            pure i-          | otherwise -> ioError e-        Right l -> do-          f l-          goH h =<< hTell h+cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()+cmdMaybe = maybe (pure ()) (throwError . T.unlines . failureMsg) <=< liftIO -    triesPerSecond = 10-    followDelayMicroseconds = 1000000 `div` triesPerSecond+cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a+cmdEither = either (throwError . T.unlines . failureMsg) pure <=< liftIO  -- | Run the benchmark program on the indicated dataset. benchmarkDataset ::+  Server ->   RunOptions ->   FutharkExe ->   FilePath ->@@ -220,77 +156,72 @@   Maybe Success ->   FilePath ->   IO (Either T.Text ([RunResult], T.Text))-benchmarkDataset opts futhark program entry input_spec expected_spec ref_out =-  -- We store the runtime in a temporary file.-  withSystemTempFile "futhark-bench" $ \tmpfile h -> do-    hClose h -- We will be writing and reading this ourselves.-    input <- getValuesBS futhark dir input_spec-    let getValuesAndBS (SuccessValues vs) = do-          vs' <- getValues futhark dir vs-          bs <- getValuesBS futhark dir vs-          return (LBS.toStrict bs, vs')-        getValuesAndBS SuccessGenerateValues =-          getValuesAndBS $ SuccessValues $ InFile ref_out-    maybe_expected <- maybe (return Nothing) (fmap Just . getValuesAndBS) expected_spec-    let options =-          runExtraOptions opts-            ++ [ "-e",-                 T.unpack entry,-                 "-t",-                 tmpfile,-                 "-r",-                 show $ runRuns opts,-                 "-b"-               ]+benchmarkDataset server opts futhark program entry input_spec expected_spec ref_out = runExceptT $ do+  output_types <- cmdEither $ cmdOutputs server entry+  input_types <- cmdEither $ cmdInputs server entry+  let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types -1]]+      ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types -1]]+      freeOuts = cmdMaybe (cmdFree server outs)+      freeIns = cmdMaybe (cmdFree server ins) -    -- Explicitly prefixing the current directory is necessary for-    -- readProcessWithExitCode to find the binary when binOutputf has-    -- no program component.-    let (to_run, to_run_args)-          | null $ runRunner opts = ("." </> binaryName program, options)-          | otherwise = (runRunner opts, binaryName program : options)+  cmdMaybe . liftIO $ cmdClear server -    when (runVerbose opts > 1) $-      putStrLn $-        unwords-          [ "Running executable",-            show to_run,-            "with arguments",-            show to_run_args-          ]+  cmdMaybe . liftIO . withValuesFile futhark dir input_spec $ \values_f ->+    cmdRestore server values_f (zip ins input_types) -    let onResult l-          | Just f <- runResultAction opts,-            [(x, "")] <- reads l =-            f x-          | otherwise =-            pure ()-    watcher <- forkIO $ follow onResult tmpfile+  let runtime l+        | Just l' <- T.stripPrefix "runtime: " l,+          [(x, "")] <- reads $ T.unpack l' =+          Just x+        | otherwise =+          Nothing -    run_res <--      timeout (runTimeout opts * 1000000) $-        readProcessWithExitCode to_run to_run_args $-          LBS.toStrict input+      doRun = do+        call_lines <- cmdEither (cmdCall server entry outs ins)+        case mapMaybe runtime call_lines of+          [call_runtime] -> do+            liftIO $ fromMaybe (const $ pure ()) (runResultAction opts) call_runtime+            return (RunResult call_runtime, call_lines)+          [] -> throwError "Could not find runtime in output."+          ls -> throwError $ "Ambiguous runtimes: " <> T.pack (show ls) -    killThread watcher+  maybe_call_logs <- liftIO . timeout (runTimeout opts * 1000000) . runExceptT $ do+    -- First one uncounted warmup run.+    void $ cmdEither $ cmdCall server entry outs ins+    freeOuts+    xs <- replicateM (runRuns opts -1) (doRun <* freeOuts)+    y <- doRun+    pure $ xs ++ [y] -    runExceptT $ case run_res of-      Just (progCode, output, progerr) -> do-        case maybe_expected of-          Nothing ->-            didNotFail program progCode $ T.decodeUtf8 progerr-          Just expected ->-            compareResult program expected-              =<< runResult program progCode output progerr-        runtime_result <- liftIO $ T.readFile tmpfile-        runtimes <- case mapM readRuntime $ T.lines runtime_result of-          Just runtimes -> return $ map RunResult runtimes-          Nothing -> throwError $ "Runtime file has invalid contents:\n" <> runtime_result+  call_logs <- case maybe_call_logs of+    Nothing ->+      throwError . T.pack $+        "Execution exceeded " ++ show (runTimeout opts) ++ " seconds."+    Just x -> liftEither x -        return (runtimes, T.decodeUtf8 progerr)-      Nothing ->-        throwError $ T.pack $ "Execution exceeded " ++ show (runTimeout opts) ++ " seconds."+  freeIns++  report <- cmdEither $ cmdReport server++  vs <- readResults server outs program <* freeOuts++  maybe_expected <-+    liftIO $ maybe (return Nothing) (fmap Just . getExpectedValues) expected_spec++  case maybe_expected of+    Just expected -> checkResult program expected vs+    Nothing -> pure ()++  return+    ( map fst call_logs,+      T.unlines $ map (T.unlines . snd) call_logs <> report+    )   where+    getExpectedValues (SuccessValues vs) =+      getValues futhark dir vs+    getExpectedValues SuccessGenerateValues =+      getExpectedValues $ SuccessValues $ InFile ref_out+     dir = takeDirectory program  -- | How to compile a benchmark.@@ -328,7 +259,7 @@         liftIO $           readProcessWithExitCode             futhark-            ( [compBackend opts, program, "-o", binaryName program]+            ( [compBackend opts, program, "-o", binaryName program, "--server"]                 <> compOptions opts             )             ""

@@ -13,10 +13,10 @@ import qualified Data.Text as T import Data.Tree import Futhark.Bench+import Futhark.Server import Futhark.Test import Futhark.Util (maxinum) import Futhark.Util.Options-import System.Console.GetOpt import System.Environment (getExecutablePath) import System.Exit import System.FilePath@@ -49,23 +49,14 @@         compOptions = mempty       } -runOptions :: Path -> Int -> AutotuneOptions -> RunOptions-runOptions path timeout_s opts =+runOptions :: Int -> AutotuneOptions -> RunOptions+runOptions timeout_s opts =   RunOptions-    { runRunner = "",-      runRuns = optRuns opts,-      runExtraOptions =-        "--default-threshold" :-        show (optDefaultThreshold opts) :-        "-L" :-        map opt path-          ++ optExtraOptions opts,+    { runRuns = optRuns opts,       runTimeout = timeout_s,       runVerbose = optVerbose opts,       runResultAction = Nothing     }-  where-    opt (name, val) = "--size=" ++ name ++ "=" ++ show val  type Path = [(String, Int)] @@ -88,6 +79,16 @@  type DatasetName = String +serverOptions :: Path -> AutotuneOptions -> [String]+serverOptions path opts =+  "--default-threshold" :+  show (optDefaultThreshold opts) :+  "-L" :+  map opt path+    ++ optExtraOptions opts+  where+    opt (name, val) = "--size=" ++ name ++ "=" ++ show val+ prepare :: AutotuneOptions -> FutharkExe -> FilePath -> IO [(DatasetName, RunDataset, T.Text)] prepare opts futhark prog = do   spec <- testSpecFromFileOrDie prog@@ -118,15 +119,11 @@               Just (runDescription trun, run entry_point trun expected)           _ -> Nothing -  fmap concat $-    forM truns $ \ios ->-      forM-        ( mapMaybe-            (runnableDataset $ iosEntryPoint ios)-            (iosTestRuns ios)-        )-        $ \(dataset, do_run) ->-          return (dataset, do_run, iosEntryPoint ios)+  fmap concat . forM truns $ \ios -> do+    let cases =+          mapMaybe (runnableDataset $ iosEntryPoint ios) (iosTestRuns ios)+    forM cases $ \(dataset, do_run) ->+      return (dataset, do_run, iosEntryPoint ios)   where     run entry_point trun expected timeout path = do       let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int)@@ -135,20 +132,26 @@               minimum $ map runMicroseconds runres             ) -          ropts = runOptions path timeout opts+          ropts = runOptions timeout opts        when (optVerbose opts > 1) $-        putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts)+        putStrLn $ "Running with options: " ++ unwords (serverOptions path opts) -      either (Left . T.unpack) (Right . bestRuntime)-        <$> benchmarkDataset-          ropts-          futhark-          prog-          entry_point-          (runInput trun)-          expected-          (testRunReferenceOutput prog entry_point trun)+      -- XXX: it is really inefficient to start a new server for every+      -- run, but unfortunately we can only set threshold parameters+      -- on startup.+      let progbin = "." </> dropExtension prog+      withServer progbin (serverOptions path opts) $ \server ->+        either (Left . T.unpack) (Right . bestRuntime)+          <$> benchmarkDataset+            server+            ropts+            futhark+            prog+            entry_point+            (runInput trun)+            expected+            (testRunReferenceOutput prog entry_point trun)  --- Benchmarking a program 

@@ -10,21 +10,24 @@ import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Either+import Data.Function ((&)) import Data.IORef import Data.List (foldl', sortBy)+import qualified Data.Map as M import Data.Maybe import Data.Ord import qualified Data.Text as T import Futhark.Bench+import Futhark.Server import Futhark.Test import Futhark.Util (fancyTerminal, maxinum, maybeNth, pmapIO) import Futhark.Util.Console import Futhark.Util.Options import System.Console.ANSI (clearLine)-import System.Console.GetOpt import System.Directory import System.Environment import System.Exit+import System.FilePath import System.IO import Text.Printf import Text.Regex.TDFA@@ -161,20 +164,31 @@   where     hasRuns (InputOutputs _ runs) = not $ null runs +withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO a) -> IO a+withProgramServer program runner extra_options f = do+  -- Explicitly prefixing the current directory is necessary for+  -- readProcessWithExitCode to find the binary when binOutputf has+  -- no path component.+  let binOutputf = dropExtension program+      binpath = "." </> binOutputf++      (to_run, to_run_args)+        | null runner = (binpath, extra_options)+        | otherwise = (runner, binpath : extra_options)++  liftIO $ withServer to_run to_run_args f+ runBenchmark :: BenchOptions -> FutharkExe -> (FilePath, [InputOutputs]) -> IO [BenchResult]-runBenchmark opts futhark (program, cases) = mapM forInputOutputs $ filter relevant cases+runBenchmark opts futhark (program, cases) = do+  (tuning_opts, tuning_desc) <- determineTuning (optTuning opts) program+  let runopts = "-L" : optExtraOptions opts ++ tuning_opts+  withProgramServer program (optRunner opts) runopts $ \server ->+    mapM (forInputOutputs server tuning_desc) $ filter relevant cases   where-    forInputOutputs (InputOutputs entry_name runs) = do-      (tuning_opts, tuning_desc) <- determineTuning (optTuning opts) program-+    forInputOutputs server tuning_desc (InputOutputs entry_name runs) = do       putStr $ inBold $ "\nResults for " ++ program' ++ tuning_desc ++ ":\n"-      let opts' =-            opts-              { optExtraOptions =-                  optExtraOptions opts ++ tuning_opts-              }       BenchResult program' . catMaybes-        <$> mapM (runBenchmarkCase opts' futhark program entry_name pad_to) runs+        <$> mapM (runBenchmarkCase server opts futhark program entry_name pad_to) runs       where         program' =           if entry_name == "main"@@ -188,9 +202,7 @@ runOptions :: (Int -> IO ()) -> BenchOptions -> RunOptions runOptions f opts =   RunOptions-    { runRunner = optRunner opts,-      runRuns = optRuns opts,-      runExtraOptions = optExtraOptions opts,+    { runRuns = optRuns opts,       runTimeout = optTimeout opts,       runVerbose = optVerbose opts,       runResultAction = Just f@@ -254,6 +266,7 @@       ((maxinum runtimes / avg - 1) * 100)  runBenchmarkCase ::+  Server ->   BenchOptions ->   FutharkExe ->   FilePath ->@@ -261,12 +274,12 @@   Int ->   TestRun ->   IO (Maybe DataResult)-runBenchmarkCase _ _ _ _ _ (TestRun _ _ RunTimeFailure {} _ _) =+runBenchmarkCase _ _ _ _ _ _ (TestRun _ _ RunTimeFailure {} _ _) =   return Nothing -- Not our concern, we are not a testing tool.-runBenchmarkCase opts _ _ _ _ (TestRun tags _ _ _ _)+runBenchmarkCase _ opts _ _ _ _ (TestRun tags _ _ _ _)   | any (`elem` tags) $ optExcludeCase opts =     return Nothing-runBenchmarkCase opts futhark program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do+runBenchmarkCase server opts futhark program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do   prompt <- mkProgressPrompt (optRuns opts) pad_to dataset_desc    -- Report the dataset name before running the program, so that if an@@ -275,6 +288,7 @@    res <-     benchmarkDataset+      server       (runOptions (prompt . Just) opts)       futhark       program@@ -297,7 +311,20 @@         putStr $ descString dataset_desc pad_to        reportResult runtimes-      return $ Just $ DataResult dataset_desc $ Right (runtimes, errout)+      Result runtimes (getMemoryUsage errout) errout+        & Right+        & DataResult dataset_desc+        & Just+        & return++getMemoryUsage :: T.Text -> M.Map T.Text Int+getMemoryUsage t =+  foldMap matchMap $ T.lines t+  where+    mem_regex = "Peak memory usage for space '([^']+)': ([0-9]+) bytes." :: T.Text+    matchMap line = case (line =~ mem_regex :: (T.Text, T.Text, T.Text, [T.Text])) of+      (_, _, _, [device, bytes]) -> M.singleton device (read $ T.unpack bytes)+      _ -> mempty  commandLineOptions :: [FunOptDescr BenchOptions] commandLineOptions =

@@ -7,7 +7,6 @@ import Futhark.Util.Options import Futhark.Util.Pretty (pretty) import Language.Futhark.Warnings-import System.Console.GetOpt import System.IO  newtype CheckConfig = CheckConfig {checkWarn :: Bool}

@@ -11,8 +11,8 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Vector.Generic (freeze)-import qualified Data.Vector.Unboxed as UVec-import qualified Data.Vector.Unboxed.Mutable as UMVec+import qualified Data.Vector.Storable as SVec+import qualified Data.Vector.Storable.Mutable as USVec import Data.Word import Futhark.Test.Values import Futhark.Util.Options@@ -26,7 +26,6 @@     Value,     ValueType,   )-import System.Console.GetOpt import System.Exit import System.IO import System.Random.PCG (Variate, initialize, uniformR)@@ -171,17 +170,17 @@   Either String (RandomConfiguration -> OutputFormat -> Word64 -> IO ()) tryMakeGenerator t   | Just vs <- readValues $ BS.pack t =-    return $ \_ fmt _ -> mapM_ (putValue fmt) vs+    return $ \_ fmt _ -> mapM_ (outValue fmt) vs   | otherwise = do     t' <- toValueType =<< either (Left . show) Right (parseType name (T.pack t))     return $ \conf fmt seed -> do       let v = randomValue conf t' seed-      putValue fmt v+      outValue fmt v   where     name = "option " ++ t-    putValue Text = putStrLn . pretty-    putValue Binary = BS.putStr . Bin.encode-    putValue Type = putStrLn . pretty . valueType+    outValue Text = putStrLn . pretty+    outValue Binary = BS.putStr . Bin.encode+    outValue Type = putStrLn . pretty . valueType  toValueType :: UncheckedTypeExp -> Either String ValueType toValueType TETuple {} = Left "Cannot handle tuples yet."@@ -282,9 +281,9 @@     gen range final = randomVector (range conf) final ds seed  randomVector ::-  (UMVec.Unbox v, Variate v) =>+  (SVec.Storable v, Variate v) =>   Range v ->-  (UVec.Vector Int -> UVec.Vector v -> Value) ->+  (SVec.Vector Int -> SVec.Vector v -> Value) ->   [Int] ->   Word64 ->   Value@@ -292,15 +291,15 @@   -- USe some nice impure computation where we can preallocate a   -- vector of the desired size, populate it via the random number   -- generator, and then finally reutrn a frozen binary vector.-  arr <- UMVec.new n+  arr <- USVec.new n   g <- initialize 6364136223846793006 seed   let fill i         | i < n = do           v <- uniformR range g-          UMVec.write arr i v+          USVec.write arr i v           fill $! i + 1         | otherwise =-          final (UVec.fromList ds) <$> freeze arr+          final (SVec.fromList ds) . SVec.convert <$> freeze arr   fill 0   where     n = product ds

@@ -50,9 +50,9 @@ import Futhark.Util.Log import Futhark.Util.Options import qualified Futhark.Util.Pretty as PP+import Language.Futhark.Core (nameFromString) import Language.Futhark.Parser (parseFuthark) import qualified Language.SexpGrammar as Sexp-import System.Console.GetOpt import System.Exit import System.FilePath import System.IO@@ -474,6 +474,19 @@       ["safe"]       (NoArg $ Right $ changeFutharkConfig $ \opts -> opts {futharkSafe = True})       "Ignore 'unsafe'.",+    Option+      []+      ["entry-points"]+      ( ReqArg+          ( \arg -> Right $+              changeFutharkConfig $ \opts ->+                opts+                  { futharkEntryPoints = nameFromString arg : futharkEntryPoints opts+                  }+          )+          "NAME"+      )+      "Treat this function as an additional entry point.",     typedPassOption soacsProg Seq firstOrderTransform "f",     soacsPassOption fuseSOACs "o",     soacsPassOption inlineFunctions [],@@ -561,6 +574,8 @@               . intersperse ""               . map (if futharkPrintAST config then show else pretty) +          readProgram' = readProgram (futharkEntryPoints (futharkConfig config)) file+       case futharkPipeline config of         PrettyPrint -> liftIO $ do           maybe_prog <- parseFuthark file <$> T.readFile file@@ -570,7 +585,7 @@               | futharkPrintAST config -> print prog               | otherwise -> putStrLn $ pretty prog         TypeCheck -> do-          (_, imports, _) <- readProgram file+          (_, imports, _) <- readProgram'           liftIO $             forM_ (map snd imports) $ \fm ->               putStrLn $@@ -578,17 +593,17 @@                   then show $ fileProg fm                   else pretty $ fileProg fm         Defunctorise -> do-          (_, imports, src) <- readProgram file+          (_, imports, src) <- readProgram'           liftIO $ p $ evalState (Defunctorise.transformProg imports) src         Monomorphise -> do-          (_, imports, src) <- readProgram file+          (_, imports, src) <- readProgram'           liftIO $             p $               flip evalState src $                 Defunctorise.transformProg imports                   >>= Monomorphise.transformProg         LiftLambdas -> do-          (_, imports, src) <- readProgram file+          (_, imports, src) <- readProgram'           liftIO $             p $               flip evalState src $@@ -596,7 +611,7 @@                   >>= Monomorphise.transformProg                   >>= LiftLambdas.transformProg         Defunctionalise -> do-          (_, imports, src) <- readProgram file+          (_, imports, src) <- readProgram'           liftIO $             p $               flip evalState src $

@@ -17,7 +17,6 @@ import Futhark.Util (directoryContents, trim) import Futhark.Util.Options import Language.Futhark.Syntax (DocComment (..), progDoc)-import System.Console.GetOpt import System.Directory (createDirectoryIfMissing) import System.Exit import System.FilePath@@ -50,7 +49,7 @@             liftIO $ do               mapM_ (hPutStrLn stderr . ("Found source file " <>)) files               hPutStrLn stderr "Reading files..."-          (_w, imports, _vns) <- readLibrary files+          (_w, imports, _vns) <- readLibrary [] files           liftIO $ printDecs config outdir files $ nubBy sameImport imports      sameImport (x, _) (y, _) = x == y

@@ -0,0 +1,742 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | @futhark literate@+module Futhark.CLI.Literate (main) where++import Control.Monad.Except+import Data.Bifunctor (bimap, first, second)+import Data.Bits+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Functor+import Data.Int (Int64)+import Data.List (foldl', transpose)+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Vector.Storable as SVec+import Data.Void+import Futhark.Script+import Futhark.Server+import Futhark.Test+import Futhark.Test.Values+import Futhark.Util (nubOrd, runProgramWithExitCode)+import Futhark.Util.Options+import Futhark.Util.Pretty (prettyText, prettyTextOneLine)+import qualified Futhark.Util.Pretty as PP+import System.Directory+  ( createDirectoryIfMissing,+    removeFile,+    removePathForcibly,+  )+import System.Environment (getExecutablePath)+import System.Exit+import System.FilePath+import System.IO+import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)+import Text.Megaparsec hiding (failure, token)+import Text.Megaparsec.Char+import Text.Printf++data AnimParams = AnimParams+  { animFPS :: Maybe Int,+    animLoop :: Maybe Bool,+    animAutoplay :: Maybe Bool,+    animFormat :: Maybe T.Text+  }+  deriving (Show)++defaultAnimParams :: AnimParams+defaultAnimParams =+  AnimParams+    { animFPS = Nothing,+      animLoop = Nothing,+      animAutoplay = Nothing,+      animFormat = Nothing+    }++data Directive+  = DirectiveRes Exp+  | DirectiveBrief Directive+  | DirectiveCovert Directive+  | DirectiveImg Exp+  | DirectivePlot Exp (Maybe (Int, Int))+  | DirectiveGnuplot Exp T.Text+  | DirectiveAnim Exp AnimParams+  deriving (Show)++varsInDirective :: Directive -> S.Set EntryName+varsInDirective (DirectiveRes e) = varsInExp e+varsInDirective (DirectiveBrief d) = varsInDirective d+varsInDirective (DirectiveCovert d) = varsInDirective d+varsInDirective (DirectiveImg e) = varsInExp e+varsInDirective (DirectivePlot e _) = varsInExp e+varsInDirective (DirectiveGnuplot e _) = varsInExp e+varsInDirective (DirectiveAnim e _) = varsInExp e++pprDirective :: Bool -> Directive -> PP.Doc+pprDirective _ (DirectiveRes e) =+  "> " <> PP.align (PP.ppr e)+pprDirective _ (DirectiveBrief f) =+  pprDirective False f+pprDirective _ (DirectiveCovert f) =+  pprDirective False f+pprDirective _ (DirectiveImg e) =+  "> :img " <> PP.align (PP.ppr e)+pprDirective True (DirectivePlot e (Just (h, w))) =+  PP.stack+    [ "> :plot2d " <> PP.ppr e <> ";",+      "size: (" <> PP.ppr w <> "," <> PP.ppr h <> ")"+    ]+pprDirective _ (DirectivePlot e _) =+  "> :plot2d " <> PP.align (PP.ppr e)+pprDirective True (DirectiveGnuplot e script) =+  PP.stack $+    "> :gnuplot " <> PP.align (PP.ppr e) <> ";" :+    map PP.strictText (T.lines script)+pprDirective False (DirectiveGnuplot e _) =+  "> :gnuplot " <> PP.align (PP.ppr e)+pprDirective False (DirectiveAnim e _) =+  "> :anim " <> PP.align (PP.ppr e)+pprDirective True (DirectiveAnim e params) =+  "> :anim " <> PP.ppr e+    <> if null params' then mempty else PP.stack $ ";" : params'+  where+    params' =+      catMaybes+        [ p "fps" animFPS PP.ppr,+          p "loop" animLoop ppBool,+          p "autoplay" animAutoplay ppBool,+          p "format" animFormat PP.strictText+        ]+    ppBool b = if b then "true" else "false"+    p s f ppr = do+      x <- f params+      Just $ s <> ": " <> ppr x++instance PP.Pretty Directive where+  ppr = pprDirective True++data Block+  = BlockCode T.Text+  | BlockComment T.Text+  | BlockDirective Directive+  deriving (Show)++varsInScripts :: [Block] -> S.Set EntryName+varsInScripts = foldMap varsInBlock+  where+    varsInBlock (BlockDirective d) = varsInDirective d+    varsInBlock BlockCode {} = mempty+    varsInBlock BlockComment {} = mempty++type Parser = Parsec Void T.Text++postlexeme :: Parser ()+postlexeme = void $ hspace *> optional (try $ eol *> "-- " *> postlexeme)++lexeme :: Parser a -> Parser a+lexeme p = p <* postlexeme++token :: T.Text -> Parser ()+token = void . try . lexeme . string++parseInt :: Parser Int+parseInt = lexeme $ read <$> some (satisfy isDigit)++restOfLine :: Parser T.Text+restOfLine = takeWhileP Nothing (/= '\n') <* eol++parseBlockComment :: Parser T.Text+parseBlockComment = T.unlines <$> some line+  where+    line = ("-- " *> restOfLine) <|> ("--" *> eol $> "")++parseTestBlock :: Parser T.Text+parseTestBlock =+  T.unlines <$> ((:) <$> header <*> remainder)+  where+    header = "-- ==" <* eol+    remainder = map ("-- " <>) . T.lines <$> parseBlockComment++parseBlockCode :: Parser T.Text+parseBlockCode = T.unlines . noblanks <$> some line+  where+    noblanks = reverse . dropWhile T.null . reverse . dropWhile T.null+    line = try (notFollowedBy "--") *> restOfLine++parsePlotParams :: Parser (Maybe (Int, Int))+parsePlotParams =+  optional $+    ";" *> hspace *> eol *> token "-- size:"+      *> token "("+      *> ((,) <$> parseInt <* token "," <*> parseInt) <* token ")"++parseAnimParams :: Parser AnimParams+parseAnimParams =+  fmap (fromMaybe defaultAnimParams) $+    optional $ ";" *> hspace *> eol *> "-- " *> parseParams defaultAnimParams+  where+    parseParams params =+      choice+        [ choice+            [pLoop params, pFPS params, pAutoplay params, pFormat params]+            >>= parseParams,+          pure params+        ]+    parseBool = token "true" $> True <|> token "false" $> False+    pLoop params = do+      token "loop:"+      b <- parseBool+      pure params {animLoop = Just b}+    pFPS params = do+      token "fps:"+      fps <- parseInt+      pure params {animFPS = Just fps}+    pAutoplay params = do+      token "autoplay:"+      b <- parseBool+      pure params {animAutoplay = Just b}+    pFormat params = do+      token "format:"+      s <- lexeme $ takeWhileP Nothing (not . isSpace)+      pure params {animFormat = Just s}++parseBlock :: Parser Block+parseBlock =+  choice+    [ token "-- >" $> BlockDirective <*> parseDirective <* void eol,+      BlockCode <$> parseTestBlock,+      BlockCode <$> parseBlockCode,+      BlockComment <$> parseBlockComment+    ]+  where+    parseDirective =+      choice+        [ DirectiveRes <$> parseExp postlexeme,+          directiveName "covert" $> DirectiveCovert+            <*> parseDirective,+          directiveName "brief" $> DirectiveBrief+            <*> parseDirective,+          directiveName "img" $> DirectiveImg+            <*> parseExp postlexeme,+          directiveName "plot2d" $> DirectivePlot+            <*> parseExp postlexeme+            <*> parsePlotParams,+          directiveName "gnuplot" $> DirectiveGnuplot+            <*> parseExp postlexeme+            <*> (";" *> hspace *> eol *> parseBlockComment),+          directiveName "anim" $> DirectiveAnim+            <*> parseExp postlexeme+            <*> parseAnimParams+        ]+    directiveName s = try $ token (":" <> s)++parseProg :: FilePath -> T.Text -> Either T.Text [Block]+parseProg fname s =+  either (Left . T.pack . errorBundlePretty) Right $+    parse (many parseBlock <* eof) fname s++parseProgFile :: FilePath -> IO [Block]+parseProgFile prog = do+  pres <- parseProg prog <$> T.readFile prog+  case pres of+    Left err -> do+      T.hPutStr stderr err+      exitFailure+    Right script ->+      pure script++type ScriptM = ExceptT T.Text IO++withTempFile :: (FilePath -> ScriptM a) -> ScriptM a+withTempFile f =+  join . liftIO . withSystemTempFile "futhark-literate" $ \tmpf tmpf_h -> do+    hClose tmpf_h+    either throwError pure <$> runExceptT (f tmpf)++withTempDir :: (FilePath -> ScriptM a) -> ScriptM a+withTempDir f =+  join . liftIO . withSystemTempDirectory "futhark-literate" $ \dir ->+    either throwError pure <$> runExceptT (f dir)++ppmHeader :: Int -> Int -> BS.ByteString+ppmHeader h w =+  "P6\n" <> BS.pack (show w) <> " " <> BS.pack (show h) <> "\n255\n"++rgbIntToImg ::+  (Integral a, Bits a, SVec.Storable a) =>+  Int ->+  Int ->+  SVec.Vector a ->+  BS.ByteString+rgbIntToImg h w bytes =+  ppmHeader h w <> fst (BS.unfoldrN (h * w * 3) byte 0)+  where+    getChan word chan =+      (word `shiftR` (chan * 8)) .&. 0xFF+    byte i =+      Just+        ( chr . max 0 . fromIntegral $+            getChan (bytes SVec.! (i `div` 3)) (2 - (i `mod` 3)),+          i + 1+        )++greyFloatToImg ::+  (RealFrac a, SVec.Storable a) =>+  Int ->+  Int ->+  SVec.Vector a ->+  BS.ByteString+greyFloatToImg h w bytes =+  ppmHeader h w <> fst (BS.unfoldrN (h * w * 3) byte 0)+  where+    byte i =+      Just (chr . max 0 $ round (bytes SVec.! (i `div` 3)) * 255, i + 1)++valueToPPM :: Value -> Maybe BS.ByteString+valueToPPM v@(Word32Value _ bytes)+  | [h, w] <- valueShape v =+    Just $ rgbIntToImg h w bytes+valueToPPM v@(Int32Value _ bytes)+  | [h, w] <- valueShape v =+    Just $ rgbIntToImg h w bytes+valueToPPM v@(Float32Value _ bytes)+  | [h, w] <- valueShape v =+    Just $ greyFloatToImg h w bytes+valueToPPM v@(Float64Value _ bytes)+  | [h, w] <- valueShape v =+    Just $ greyFloatToImg h w bytes+valueToPPM _ = Nothing++valueToPPMs :: Value -> Maybe [BS.ByteString]+valueToPPMs = mapM valueToPPM . valueElems++system :: FilePath -> [String] -> T.Text -> ScriptM T.Text+system prog options input = do+  res <- liftIO $ runProgramWithExitCode prog options $ T.encodeUtf8 input+  case res of+    Left err ->+      throwError $ prog' <> " failed: " <> T.pack (show err)+    Right (ExitSuccess, stdout_t, _) ->+      pure $ T.pack stdout_t+    Right (ExitFailure code', _, stderr_t) ->+      throwError $+        prog' <> " failed with exit code "+          <> T.pack (show code')+          <> " and stderr:\n"+          <> T.pack stderr_t+  where+    prog' = "'" <> T.pack prog <> "'"++ppmToPNG :: FilePath -> ScriptM FilePath+ppmToPNG ppm = do+  void $ system "convert" [ppm, png] mempty+  pure png+  where+    png = ppm `replaceExtension` "png"++formatDataForGnuplot :: [Value] -> T.Text+formatDataForGnuplot = T.unlines . map line . transpose . map valueElems+  where+    line = T.unwords . map prettyText++imgBlock :: FilePath -> T.Text+imgBlock f = "\n\n![](" <> T.pack f <> ")\n\n"++videoBlock :: AnimParams -> FilePath -> T.Text+videoBlock opts f = "\n\n![](" <> T.pack f <> ")" <> opts' <> "\n\n"+  where+    opts'+      | all T.null [loop, autoplay] =+        mempty+      | otherwise =+        "{" <> T.unwords [loop, autoplay] <> "}"+    boolOpt s prop+      | Just b <- prop opts =+        if b then s <> "=\"true\"" else s <> "=\"false\""+      | otherwise =+        mempty+    loop = boolOpt "loop" animLoop+    autoplay = boolOpt "autoplay" animAutoplay++plottable :: CompoundValue -> Maybe [Value]+plottable (ValueTuple vs) = do+  (vs', ns') <- unzip <$> mapM inspect vs+  guard $ length (nubOrd ns') == 1+  Just vs'+  where+    inspect (ValueAtom v)+      | [n] <- valueShape v = Just (v, n)+    inspect _ = Nothing+plottable _ = Nothing++withGnuplotData ::+  [(T.Text, T.Text)] ->+  [(T.Text, [Value])] ->+  ([T.Text] -> [T.Text] -> ScriptM a) ->+  ScriptM a+withGnuplotData sets [] cont = uncurry cont $ unzip $ reverse sets+withGnuplotData sets ((f, vs) : xys) cont =+  withTempFile $ \fname -> do+    liftIO $ T.writeFile fname $ formatDataForGnuplot vs+    withGnuplotData ((f, f <> "='" <> T.pack fname <> "'") : sets) xys cont++processDirective :: FilePath -> ScriptServer -> Int -> Directive -> ScriptM T.Text+processDirective imgdir server i (DirectiveBrief d) =+  processDirective imgdir server i d+processDirective imgdir server i (DirectiveCovert d) =+  processDirective imgdir server i d+processDirective _ server _ (DirectiveRes e) = do+  vs <- evalExpToGround server e+  pure $+    T.unlines+      [ "",+        "```",+        prettyText vs,+        "```",+        ""+      ]+--+processDirective imgdir server i (DirectiveImg e) = do+  vs <- evalExpToGround server e+  case vs of+    ValueAtom v+      | Just ppm <- valueToPPM v -> do+        let ppmfile = imgdir </> "img" <> show i <.> ".ppm"+        liftIO $ createDirectoryIfMissing True imgdir+        liftIO $ BS.writeFile ppmfile ppm+        pngfile <- ppmToPNG ppmfile+        liftIO $ removeFile ppmfile+        pure $ imgBlock pngfile+    _ ->+      throwError $+        "Cannot create image from value of type "+          <> prettyText (fmap valueType vs)+--+processDirective imgdir server i (DirectivePlot e size) = do+  v <- evalExpToGround server e+  case v of+    _+      | Just vs <- plottable2d v ->+        plotWith [(Nothing, vs)]+    ValueRecord m+      | Just m' <- traverse plottable2d m ->+        plotWith $ map (first Just) $ M.toList m'+    _ ->+      throwError $+        "Cannot plot value of type " <> prettyText (fmap valueType v)+  where+    plottable2d v = do+      [x, y] <- plottable v+      Just [x, y]++    pngfile = imgdir </> "plot" <> show i <.> ".png"++    tag (Nothing, xys) j = ("data" <> T.pack (show (j :: Int)), xys)+    tag (Just f, xys) _ = (f, xys)++    plotWith xys = withGnuplotData [] (zipWith tag xys [0 ..]) $ \fs sets -> do+      liftIO $ createDirectoryIfMissing True imgdir+      let size' = T.pack $+            case size of+              Nothing -> "500,500"+              Just (w, h) -> show w ++ "," ++ show h+          plotCmd f title =+            let title' = case title of+                  Nothing -> "notitle"+                  Just x -> "title '" <> x <> "'"+             in f <> " " <> title' <> " with lines"+          cmds = T.intercalate ", " (zipWith plotCmd fs (map fst xys))+          script =+            T.unlines+              [ "set terminal png size " <> size' <> " enhanced",+                "set output '" <> T.pack pngfile <> "'",+                "set key outside",+                T.unlines sets,+                "plot " <> cmds+              ]+      void $ system "gnuplot" [] script+      pure $ imgBlock pngfile+--+processDirective imgdir server i (DirectiveGnuplot e script) = do+  vs <- evalExpToGround server e+  case vs of+    ValueRecord m+      | Just m' <- traverse plottable m ->+        plotWith $ M.toList m'+    _ ->+      throwError $+        "Cannot plot value of type " <> prettyText (fmap valueType vs)+  where+    pngfile = imgdir </> "plot" <> show i <.> ".png"++    plotWith xys = withGnuplotData [] xys $ \_ sets -> do+      liftIO $ createDirectoryIfMissing True imgdir+      let script' =+            T.unlines+              [ "set terminal png enhanced",+                "set output '" <> T.pack pngfile <> "'",+                T.unlines sets,+                script+              ]+      void $ system "gnuplot" [] script'+      pure $ imgBlock pngfile+--+processDirective imgdir server i (DirectiveAnim e params) = do+  when (format `notElem` ["webm", "gif"]) $+    throwError $ "Unknown animation format: " <> format++  v <- evalExp server e+  let nope =+        throwError $+          "Cannot animate value of type " <> prettyText (fmap scriptValueType v)+  case v of+    ValueAtom SValue {} -> do+      ValueAtom arr <- getExpValue server v+      case valueToPPMs arr of+        Nothing -> nope+        Just ppms ->+          withTempDir $ \dir -> do+            zipWithM_ (writePPMFile dir) [0 ..] ppms+            ppmsToVideo dir+    ValueTuple [stepfun, initial, num_frames]+      | ValueAtom (SFun stepfun' _ [_, _] closure) <- stepfun,+        ValueAtom (SValue _ _) <- initial,+        ValueAtom (SValue "i64" _) <- num_frames -> do+        Just (ValueAtom num_frames') <-+          mapM getValue <$> getExpValue server num_frames+        withTempDir $ \dir -> do+          let num_frames_int = fromIntegral (num_frames' :: Int64)+          renderFrames dir (stepfun', map ValueAtom closure) initial num_frames_int+          ppmsToVideo dir+    _ ->+      nope++  when (animFormat params == Just "gif") $ do+    void $ system "ffmpeg" ["-i", webmfile, giffile] mempty+    liftIO $ removeFile webmfile++  pure $ videoBlock params animfile+  where+    framerate = fromMaybe 30 $ animFPS params+    format = fromMaybe "webm" $ animFormat params+    webmfile = imgdir </> "anim" <> show i <.> "webm"+    giffile = imgdir </> "anim" <> show i <.> "gif"+    ppmfile dir j = dir </> printf "frame%010d.ppm" (j :: Int)+    animfile = imgdir </> "anim" <> show i <.> T.unpack format++    renderFrames dir (stepfun, closure) initial num_frames =+      foldM_ frame initial [0 .. num_frames -1]+      where+        frame old_state j = do+          v <- evalExp server . Call stepfun . map valueToExp $ closure ++ [old_state]+          freeValue server old_state++          let nope =+                throwError $+                  "Cannot handle step function return type: "+                    <> prettyText (fmap scriptValueType v)++          case v of+            ValueTuple [arr_v@(ValueAtom SValue {}), new_state] -> do+              ValueAtom arr <- getExpValue server arr_v+              freeValue server arr_v+              case valueToPPM arr of+                Nothing -> nope+                Just ppm -> do+                  writePPMFile dir j ppm+                  pure new_state+            _ -> nope++    ppmsToVideo dir = do+      liftIO $ createDirectoryIfMissing True imgdir+      void $+        system+          "ffmpeg"+          [ "-y",+            "-r",+            show framerate,+            "-i",+            dir </> "frame%010d.ppm",+            "-c:v",+            "libvpx-vp9",+            "-pix_fmt",+            "yuv420p",+            "-b:v",+            "2M",+            webmfile+          ]+          mempty++    writePPMFile dir j ppm = do+      let fname = ppmfile dir j+      liftIO $ BS.writeFile fname ppm++-- Did this script block succeed or fail?+data Failure = Failure | Success+  deriving (Eq, Ord, Show)++data Options = Options+  { scriptBackend :: String,+    scriptFuthark :: Maybe FilePath,+    scriptExtraOptions :: [String],+    scriptCompilerOptions :: [String],+    scriptSkipCompilation :: Bool,+    scriptOutput :: Maybe FilePath,+    scriptVerbose :: Int,+    scriptStopOnError :: Bool+  }++initialOptions :: Options+initialOptions =+  Options+    { scriptBackend = "c",+      scriptFuthark = Nothing,+      scriptExtraOptions = [],+      scriptCompilerOptions = [],+      scriptSkipCompilation = False,+      scriptOutput = Nothing,+      scriptVerbose = 0,+      scriptStopOnError = False+    }++processBlock :: Options -> FilePath -> ScriptServer -> Int -> Block -> IO (Failure, T.Text)+processBlock _ _ _ _ (BlockCode code)+  | T.null code = pure (Success, "\n")+  | otherwise = pure (Success, "\n```futhark\n" <> code <> "```\n\n")+processBlock _ _ _ _ (BlockComment text) =+  pure (Success, text)+processBlock opts imgdir server i (BlockDirective directive) = do+  when (scriptVerbose opts > 0) $+    T.hPutStrLn stderr . prettyText $+      "Processing " <> PP.align (PP.ppr directive) <> "..."+  let prompt = case directive of+        DirectiveCovert _ -> mempty+        DirectiveBrief _ ->+          "```\n" <> prettyText (pprDirective False directive) <> "\n```\n"+        _ ->+          "```\n" <> prettyText (pprDirective True directive) <> "\n```\n"+  r <- runExceptT $ processDirective imgdir server i directive+  second (prompt <>) <$> case r of+    Left err -> failed err+    Right t -> pure (Success, t)+  where+    failed err = do+      let message = prettyTextOneLine directive <> " failed:\n" <> err <> "\n"+      liftIO $ T.hPutStr stderr message+      when (scriptStopOnError opts) exitFailure+      pure+        ( Failure,+          T.unlines ["**FAILED**", "```", err, "```"]+        )++processScript :: Options -> FilePath -> ScriptServer -> [Block] -> IO (Failure, T.Text)+processScript opts imgdir server script =+  bimap (foldl' min Success) mconcat . unzip+    <$> zipWithM (processBlock opts imgdir server) [0 ..] script++commandLineOptions :: [FunOptDescr Options]+commandLineOptions =+  [ Option+      []+      ["backend"]+      ( ReqArg+          (\backend -> Right $ \config -> config {scriptBackend = backend})+          "PROGRAM"+      )+      "The compiler used (defaults to 'c').",+    Option+      []+      ["futhark"]+      ( ReqArg+          (\prog -> Right $ \config -> config {scriptFuthark = Just prog})+          "PROGRAM"+      )+      "The binary used for operations (defaults to same binary as 'futhark script').",+    Option+      "p"+      ["pass-option"]+      ( ReqArg+          ( \opt ->+              Right $ \config ->+                config {scriptExtraOptions = opt : scriptExtraOptions config}+          )+          "OPT"+      )+      "Pass this option to programs being run.",+    Option+      []+      ["pass-compiler-option"]+      ( ReqArg+          ( \opt ->+              Right $ \config ->+                config {scriptCompilerOptions = opt : scriptCompilerOptions config}+          )+          "OPT"+      )+      "Pass this option to the compiler.",+    Option+      []+      ["skip-compilation"]+      (NoArg $ Right $ \config -> config {scriptSkipCompilation = True})+      "Use already compiled program.",+    Option+      "v"+      ["verbose"]+      (NoArg $ Right $ \config -> config {scriptVerbose = scriptVerbose config + 1})+      "Enable logging.  Pass multiple times for more.",+    Option+      "o"+      ["output"]+      (ReqArg (\opt -> Right $ \config -> config {scriptOutput = Just opt}) "FILE")+      "Enable logging.  Pass multiple times for more.",+    Option+      []+      ["stop-on-error"]+      (NoArg $ Right $ \config -> config {scriptStopOnError = True})+      "Stop and do not produce output file if any directive fails."+  ]++-- | Run @futhark script@.+main :: String -> [String] -> IO ()+main = mainWithOptions initialOptions commandLineOptions "program" $ \args opts ->+  case args of+    [prog] -> Just $ do+      futhark <- maybe getExecutablePath return $ scriptFuthark opts++      script <- parseProgFile prog++      unless (scriptSkipCompilation opts) $ do+        let entryOpt v = "--entry=" ++ T.unpack v+            compile_options =+              "--server" :+              map entryOpt (S.toList (varsInScripts script))+                ++ scriptCompilerOptions opts+        when (scriptVerbose opts > 0) $+          T.hPutStrLn stderr $ "Compiling " <> T.pack prog <> "..."+        cres <-+          runExceptT $+            compileProgram compile_options (FutharkExe futhark) (scriptBackend opts) prog+        case cres of+          Left err -> do+            mapM_ (T.hPutStrLn stderr) err+            exitFailure+          Right _ ->+            pure ()++      let mdfile = fromMaybe (prog `replaceExtension` "md") $ scriptOutput opts+          imgdir = dropExtension mdfile <> "-img"+          run_options = scriptExtraOptions opts++      removePathForcibly imgdir++      withScriptServer ("." </> dropExtension prog) run_options $ \server -> do+        (failure, md) <- processScript opts imgdir server script+        when (failure == Failure) exitFailure+        T.writeFile mdfile md+    _ -> Nothing

@@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} +-- | @futhark multicore@ module Futhark.CLI.Multicore (main) where  import Futhark.Actions (compileMulticoreAction) import Futhark.Compiler.CLI import Futhark.Passes (multicorePipeline) +-- | Run @futhark multicore@. main :: String -> [String] -> IO () main = compilerMain   ()

@@ -21,7 +21,6 @@ import Futhark.Util (directoryContents, maxinum) import Futhark.Util.Log import Futhark.Util.Options-import System.Console.GetOpt import System.Directory import System.Environment import System.Exit

@@ -21,14 +21,14 @@   $ \fcfg () mode outpath prog -> do     let class_name =           case mode of-            ToLibrary -> Just $ takeBaseName outpath-            ToExecutable -> Nothing-    pyprog <- handleWarnings fcfg $ PyOpenCL.compileProg class_name prog+            ToLibrary -> takeBaseName outpath+            _ -> "internal"+    pyprog <- handleWarnings fcfg $ PyOpenCL.compileProg mode class_name prog      case mode of       ToLibrary ->         liftIO $ writeFile (outpath `addExtension` "py") pyprog-      ToExecutable -> liftIO $ do+      _ -> liftIO $ do         writeFile outpath pyprog         perms <- liftIO $ getPermissions outpath         setPermissions outpath $ setOwnerExecutable True perms

@@ -21,14 +21,14 @@   $ \fcfg () mode outpath prog -> do     let class_name =           case mode of-            ToLibrary -> Just $ takeBaseName outpath-            ToExecutable -> Nothing-    pyprog <- handleWarnings fcfg $ SequentialPy.compileProg class_name prog+            ToLibrary -> takeBaseName outpath+            _ -> "internal"+    pyprog <- handleWarnings fcfg $ SequentialPy.compileProg mode class_name prog      case mode of       ToLibrary ->         liftIO $ writeFile (outpath `addExtension` "py") pyprog-      ToExecutable -> liftIO $ do+      _ -> liftIO $ do         writeFile outpath pyprog         perms <- liftIO $ getPermissions outpath         setPermissions outpath $ setOwnerExecutable True perms

@@ -31,7 +31,6 @@ import qualified Language.Futhark.Semantic as T import qualified Language.Futhark.TypeChecker as T import NeatInterpolation (text)-import System.Console.GetOpt import qualified System.Console.Haskeline as Haskeline import System.Directory import System.FilePath@@ -158,7 +157,7 @@   (imports, src, tenv, ienv) <- case maybe_file of     Nothing -> do       -- Load the builtins through the type checker.-      (_, imports, src) <- badOnLeft show =<< runExceptT (readLibrary [])+      (_, imports, src) <- badOnLeft show =<< runExceptT (readLibrary [] [])       -- Then into the interpreter.       ienv <-         foldM@@ -183,7 +182,7 @@       (ws, imports, src) <-         badOnLeft show           =<< liftIO-            ( runExceptT (readProgram file)+            ( runExceptT (readProgram [] file)                 `catch` \(err :: IOException) ->                   return (externalErrorS (show err))             )

@@ -21,7 +21,6 @@ import Language.Futhark.Parser hiding (EOF) import qualified Language.Futhark.Semantic as T import qualified Language.Futhark.TypeChecker as T-import System.Console.GetOpt import System.Exit import System.FilePath import System.IO@@ -118,7 +117,7 @@   (ws, imports, src) <-     badOnLeft show       =<< liftIO-        ( runExceptT (readProgram file)+        ( runExceptT (readProgram [] file)             `catch` \(err :: IOException) ->               return (externalErrorS (show err))         )

@@ -18,7 +18,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T-import Futhark.Analysis.Metrics+import Futhark.Analysis.Metrics.Type+import Futhark.Server import Futhark.Test import Futhark.Util (fancyTerminal) import Futhark.Util.Console@@ -26,7 +27,6 @@ import Futhark.Util.Pretty (prettyText) import Futhark.Util.Table import System.Console.ANSI-import System.Console.GetOpt import qualified System.Console.Terminal.Size as Terminal import System.Environment import System.Exit@@ -49,8 +49,8 @@ runTestM :: TestM () -> IO TestResult runTestM = fmap (either Failure $ const Success) . runExceptT -io :: IO a -> TestM a-io = liftIO+liftExcept :: ExceptT T.Text IO a -> TestM a+liftExcept = either (E.throwError . pure) pure <=< liftIO . runExceptT  context :: T.Text -> TestM a -> TestM a context s = withExceptT $@@ -58,6 +58,9 @@     [] -> []     (e : es') -> (s <> ":\n" <> e) : es' +context1 :: Monad m => T.Text -> ExceptT T.Text m a -> ExceptT T.Text m a+context1 s = withExceptT $ \e -> s <> ":\n" <> e+ accErrors :: [TestM a] -> TestM [a] accErrors tests = do   eithers <- lift $ mapM runExceptT tests@@ -72,6 +75,31 @@   | Failure [T.Text]   deriving (Eq, Show) +pureTestResults :: IO [TestResult] -> TestM ()+pureTestResults m =+  mapM_ check =<< liftIO m+  where+    check Success = pure ()+    check (Failure err) = E.throwError err++withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO [TestResult]) -> TestM ()+withProgramServer program runner extra_options f = do+  -- Explicitly prefixing the current directory is necessary for+  -- readProcessWithExitCode to find the binary when binOutputf has+  -- no path component.+  let binOutputf = dropExtension program+      binpath = "." </> binOutputf++      (to_run, to_run_args)+        | null runner = (binpath, extra_options)+        | otherwise = (runner, binpath : extra_options)++      prog_ctx =+        "Running " <> T.pack (unwords $ binpath : extra_options)++  context prog_ctx $+    pureTestResults $ liftIO $ withServer to_run to_run_args f+ data TestCase = TestCase   { _testCaseMode :: TestMode,     testCaseProgram :: FilePath,@@ -87,7 +115,7 @@   x `compare` y = testCaseProgram x `compare` testCaseProgram y  data RunResult-  = ErrorResult Int SBS.ByteString+  = ErrorResult T.Text   | SuccessResult [Value]  progNotFound :: T.Text -> T.Text@@ -108,9 +136,9 @@       check []   where     check opt = do-      futhark <- io $ maybe getExecutablePath return $ configFuthark programs+      futhark <- liftIO $ maybe getExecutablePath return $ configFuthark programs       let opts = ["dev"] ++ opt ++ ["--metrics", program]-      (code, output, err) <- io $ readProcessWithExitCode futhark opts ""+      (code, output, err) <- liftIO $ readProcessWithExitCode futhark opts ""       let output' = T.decodeUtf8 output       case code of         ExitSuccess@@ -152,187 +180,190 @@             <> T.decodeUtf8 futerr       | otherwise = return () +runInterpretedEntry :: FutharkExe -> FilePath -> InputOutputs -> TestM ()+runInterpretedEntry (FutharkExe futhark) program (InputOutputs entry run_cases) =+  let dir = takeDirectory program+      runInterpretedCase run@(TestRun _ inputValues _ index _) =+        unless ("compiled" `elem` runTags run) $+          context+            ( "Entry point: " <> entry+                <> "; dataset: "+                <> T.pack (runDescription run)+            )+            $ do+              input <- T.unlines . map prettyText <$> getValues (FutharkExe futhark) dir inputValues+              expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run+              (code, output, err) <-+                liftIO $+                  readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $+                    T.encodeUtf8 input+              case code of+                ExitFailure 127 ->+                  throwError $ progNotFound $ T.pack futhark+                _ ->+                  liftExcept $+                    compareResult entry index program expectedResult'+                      =<< runResult program code output err+   in accErrors_ $ map runInterpretedCase run_cases+ runTestCase :: TestCase -> TestM () runTestCase (TestCase mode program testcase progs) = do-  futhark <- io $ maybe getExecutablePath return $ configFuthark progs+  futhark <- liftIO $ maybe getExecutablePath return $ configFuthark progs+  let checkctx =+        mconcat+          [ "Type-checking with '",+            T.pack futhark,+            " check ",+            T.pack program,+            "'"+          ]   case testAction testcase of     CompileTimeFailure expected_error ->-      context-        ( mconcat-            [ "Type-checking with '",-              T.pack futhark,-              " check ",-              T.pack program,-              "'"-            ]-        )-        $ do-          (code, _, err) <--            io $ readProcessWithExitCode futhark ["check", program] ""-          case code of-            ExitSuccess -> throwError "Expected failure\n"-            ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark-            ExitFailure 1 -> throwError $ T.decodeUtf8 err-            ExitFailure _ -> checkError expected_error err+      context checkctx $ do+        (code, _, err) <-+          liftIO $ readProcessWithExitCode futhark ["check", program] ""+        case code of+          ExitSuccess -> throwError "Expected failure\n"+          ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+          ExitFailure 1 -> throwError $ T.decodeUtf8 err+          ExitFailure _ -> liftExcept $ checkError expected_error $ T.decodeUtf8 err     RunCases {} | mode == TypeCheck -> do       let options = ["check", program] ++ configExtraCompilerOptions progs-      context-        ( mconcat-            [ "Type-checking with '",-              T.pack futhark,-              " check ",-              T.pack program,-              "'"-            ]-        )-        $ do-          (code, _, err) <- io $ readProcessWithExitCode futhark options ""+      context checkctx $ do+        (code, _, err) <- liftIO $ readProcessWithExitCode futhark options "" -          case code of-            ExitSuccess -> return ()-            ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark-            ExitFailure _ -> throwError $ T.decodeUtf8 err+        case code of+          ExitSuccess -> return ()+          ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+          ExitFailure _ -> throwError $ T.decodeUtf8 err     RunCases ios structures warnings -> do       -- Compile up-front and reuse same executable for several entry points.       let backend = configBackend progs-          extra_options = configExtraCompilerOptions progs+          extra_compiler_options = configExtraCompilerOptions progs+       unless (mode == Compile) $         context "Generating reference outputs" $           -- We probably get the concurrency at the test program level,           -- so force just one data set at a time here.           ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios+       unless (mode == Interpreted) $         context ("Compiling with --backend=" <> T.pack backend) $ do-          compileTestProgram extra_options (FutharkExe futhark) backend program warnings+          compileTestProgram extra_compiler_options (FutharkExe futhark) backend program warnings           mapM_ (testMetrics progs program) structures           unless (mode == Compile) $ do             (tuning_opts, _) <-               liftIO $ determineTuning (configTuning progs) program-            let progs' =-                  progs-                    { configExtraOptions =-                        tuning_opts ++ configExtraOptions progs-                    }+            let extra_options = tuning_opts ++ configExtraOptions progs+                runner = configRunner progs             context "Running compiled program" $-              accErrors_ $ map (runCompiledEntry (FutharkExe futhark) program progs') ios+              withProgramServer program runner extra_options $ \server -> do+                let run = runCompiledEntry (FutharkExe futhark) server program+                concat <$> mapM run ios+       unless (mode == Compile || mode == Compiled) $         context "Interpreting" $           accErrors_ $ map (runInterpretedEntry (FutharkExe futhark) program) ios -runInterpretedEntry :: FutharkExe -> FilePath -> InputOutputs -> TestM ()-runInterpretedEntry (FutharkExe futhark) program (InputOutputs entry run_cases) =-  let dir = takeDirectory program-      runInterpretedCase run@(TestRun _ inputValues _ index _) =-        unless ("compiled" `elem` runTags run) $-          context-            ( "Entry point: " <> entry-                <> "; dataset: "-                <> T.pack (runDescription run)-            )-            $ do-              input <- T.unlines . map prettyText <$> getValues (FutharkExe futhark) dir inputValues-              expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run-              (code, output, err) <--                io $-                  readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $-                    T.encodeUtf8 input-              case code of-                ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark-                _ ->-                  compareResult entry index program expectedResult'-                    =<< runResult program code output err-   in accErrors_ $ map runInterpretedCase run_cases--runCompiledEntry :: FutharkExe -> FilePath -> ProgConfig -> InputOutputs -> TestM ()-runCompiledEntry futhark program progs (InputOutputs entry run_cases) =-  -- Explicitly prefixing the current directory is necessary for-  -- readProcessWithExitCode to find the binary when binOutputf has-  -- no path component.-  let binOutputf = dropExtension program-      binpath = "." </> binOutputf-      entry_options = ["-e", T.unpack entry]+liftCommand ::+  (MonadError T.Text m, MonadIO m) =>+  IO (Maybe CmdFailure) ->+  m ()+liftCommand m = do+  r <- liftIO m+  case r of+    Just (CmdFailure _ err) -> E.throwError $ T.unlines err+    Nothing -> pure () -      runner = configRunner progs-      extra_options = configExtraOptions progs+runCompiledEntry :: FutharkExe -> Server -> FilePath -> InputOutputs -> IO [TestResult]+runCompiledEntry futhark server program (InputOutputs entry run_cases) = do+  Right output_types <- cmdOutputs server entry+  Right input_types <- cmdInputs server entry+  let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types -1]]+      ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types -1]]+      onRes = either (Failure . pure) (const Success)+  mapM (fmap onRes . runCompiledCase input_types outs ins) run_cases+  where+    dir = takeDirectory program -      runCompiledCase run@(TestRun _ inputValues _ index _) =-        context-          ( "Entry point: " <> entry-              <> "; dataset: "+    runCompiledCase input_types outs ins run = runExceptT $ do+      let TestRun _ inputValues _ index _ = run+          case_ctx =+            "Entry point: " <> entry <> "; dataset: "               <> T.pack (runDescription run)-          )-          $ do-            expected <- getExpectedResult futhark program entry run-            (progCode, output, progerr) <--              runProgram futhark runner extra_options program entry inputValues-            compareResult entry index program expected-              =<< runResult program progCode output progerr-   in context ("Running " <> T.pack (unwords $ binpath : entry_options ++ extra_options)) $-        accErrors_ $ map runCompiledCase run_cases -checkError :: ExpectedError -> SBS.ByteString -> TestM ()+      context1 case_ctx $ do+        expected <- getExpectedResult futhark program entry run++        (liftCommand . withValuesFile futhark dir inputValues) $ \values_f ->+          cmdRestore server values_f (zip ins input_types)++        call_r <- liftIO $ cmdCall server entry outs ins+        liftCommand $ cmdFree server ins++        res <- case call_r of+          Left (CmdFailure _ err) ->+            pure $ ErrorResult $ T.unlines err+          Right _ ->+            SuccessResult+              <$> readResults server outs program+                <* liftCommand (cmdFree server outs)++        compareResult entry index program expected res++checkError :: MonadError T.Text m => ExpectedError -> T.Text -> m () checkError (ThisError regex_s regex) err-  | not (match regex $ T.unpack $ T.decodeUtf8 err) =-    throwError $+  | not (match regex $ T.unpack err) =+    E.throwError $       "Expected error:\n  " <> regex_s         <> "\nGot error:\n  "-        <> T.decodeUtf8 err+        <> err checkError _ _ =   return () -runResult :: FilePath -> ExitCode -> SBS.ByteString -> SBS.ByteString -> TestM RunResult+runResult ::+  (MonadIO m, MonadError T.Text m) =>+  FilePath ->+  ExitCode ->+  SBS.ByteString ->+  SBS.ByteString ->+  m RunResult runResult program ExitSuccess stdout_s _ =   case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of     Left e -> do       let actualf = program `addExtension` "actual"-      io $ SBS.writeFile actualf stdout_s-      throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")"+      liftIO $ SBS.writeFile actualf stdout_s+      E.throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")"     Right vs -> return $ SuccessResult vs-runResult _ (ExitFailure code) _ stderr_s =-  return $ ErrorResult code stderr_s+runResult _ (ExitFailure _) _ stderr_s =+  return $ ErrorResult $ T.decodeUtf8 stderr_s  compileTestProgram :: [String] -> FutharkExe -> String -> FilePath -> [WarningTest] -> TestM () compileTestProgram extra_options futhark backend program warnings = do-  (_, futerr) <- compileProgram extra_options futhark backend program+  (_, futerr) <- compileProgram ("--server" : extra_options) futhark backend program   testWarnings warnings futerr  compareResult ::+  (MonadIO m, MonadError T.Text m) =>   T.Text ->   Int ->   FilePath ->   ExpectedResult [Value] ->   RunResult ->-  TestM ()+  m () compareResult _ _ _ (Succeeds Nothing) SuccessResult {} =   return ()-compareResult entry index program (Succeeds (Just expectedResult)) (SuccessResult actualResult) =-  case compareValues1 actualResult expectedResult of-    Just mismatch -> do-      let actualf = program <.> T.unpack entry <.> show index <.> "actual"-          expectedf = program <.> T.unpack entry <.> show index <.> "expected"-      io $-        SBS.writeFile actualf $-          T.encodeUtf8 $ T.unlines $ map prettyText actualResult-      io $-        SBS.writeFile expectedf $-          T.encodeUtf8 $ T.unlines $ map prettyText expectedResult-      throwError $-        T.pack actualf <> " and " <> T.pack expectedf-          <> " do not match:\n"-          <> T.pack (show mismatch)-          <> "\n"-    Nothing ->-      return ()-compareResult _ _ _ (RunTimeFailure expectedError) (ErrorResult _ actualError) =+compareResult entry index program (Succeeds (Just expected_vs)) (SuccessResult actual_vs) =+  checkResult+    (program <.> T.unpack entry <.> show index)+    expected_vs+    actual_vs+compareResult _ _ _ (RunTimeFailure expectedError) (ErrorResult actualError) =   checkError expectedError actualError-compareResult _ _ _ (Succeeds _) (ErrorResult code err) =-  throwError $-    "Program failed with error code "-      <> T.pack (show code)-      <> " and stderr:\n  "-      <> T.decodeUtf8 err+compareResult _ _ _ (Succeeds _) (ErrorResult err) =+  E.throwError $ "Function failed with error:\n" <> err compareResult _ _ _ (RunTimeFailure f) (SuccessResult _) =-  throwError $ "Program succeeded, but expected failure:\n  " <> T.pack (show f)+  E.throwError $ "Program succeeded, but expected failure:\n  " <> T.pack (show f)  --- --- Test manager@@ -581,7 +612,7 @@           { configBackend = "c",             configFuthark = Nothing,             configRunner = "",-            configExtraOptions = ["-b"],+            configExtraOptions = [],             configExtraCompilerOptions = [],             configTuning = Just "tuning"           },

@@ -7,6 +7,7 @@     GC.CParts (..),     GC.asLibrary,     GC.asExecutable,+    GC.asServer,   ) where @@ -319,11 +320,11 @@       void *$id:args_arr[] = { $inits:args'' };       typename int64_t $id:time_start = 0, $id:time_end = 0;       if (ctx->debugging) {-        fprintf(stderr, "Launching %s with grid size (", $string:(pretty kernel_name));+        fprintf(ctx->log, "Launching %s with grid size (", $string:(pretty kernel_name));         $stms:(printSizes [grid_x, grid_y, grid_z])-        fprintf(stderr, ") and block size (");+        fprintf(ctx->log, ") and block size (");         $stms:(printSizes [block_x, block_y, block_z])-        fprintf(stderr, ").\n");+        fprintf(ctx->log, ").\n");         $id:time_start = get_wall_time();       }       $items:bef@@ -337,7 +338,7 @@       if (ctx->debugging) {         CUDA_SUCCEED(cuCtxSynchronize());         $id:time_end = get_wall_time();-        fprintf(stderr, "Kernel %s runtime: %ldus\n",+        fprintf(ctx->log, "Kernel %s runtime: %ldus\n",                 $string:(pretty kernel_name), $id:time_end - $id:time_start);       }     }|]@@ -370,6 +371,6 @@       return (offset, Just (size, offset))      printSizes =-      intercalate [[C.cstm|fprintf(stderr, ", ");|]] . map printSize+      intercalate [[C.cstm|fprintf(ctx->log, ", ");|]] . map printSize     printSize e =-      [[C.cstm|fprintf(stderr, "%d", $exp:e);|]]+      [[C.cstm|fprintf(ctx->log, "%ld", (long int)$exp:e);|]]

@@ -337,8 +337,10 @@                          int debugging;                          int profiling;                          int profiling_paused;+                         int logging;                          typename lock_t lock;                          char *error;+                         typename FILE *log;                          $sdecls:fields                          $sdecls:kernel_fields                          typename CUdeviceptr global_failure;@@ -371,7 +373,9 @@                  ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging;                  ctx->profiling = cfg->profiling;                  ctx->profiling_paused = 0;+                 ctx->logging = cfg->cu_cfg.logging;                  ctx->error = NULL;+                 ctx->log = stderr;                  ctx->cuda.profiling_records_capacity = 200;                  ctx->cuda.profiling_records_used = 0;                  ctx->cuda.profiling_records =@@ -458,12 +462,7 @@                }|]     ) -  GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->-    ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],-      [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                         lock_lock(&ctx->lock);-                         CUDA_SUCCEED(cuda_free_all(&ctx->cuda));-                         lock_unlock(&ctx->lock);-                         return 0;-                       }|]-    )+  GC.onClear+    [C.citem|if (ctx->error == NULL) {+               CUDA_SUCCEED(cuda_free_all(&ctx->cuda));+             }|]

@@ -8,6 +8,7 @@     GC.CParts (..),     GC.asLibrary,     GC.asExecutable,+    GC.asServer,   ) where @@ -318,7 +319,7 @@   GC.stm [C.cstm|$id:v = ctx->sizes.$id:key <= $exp:x';|]   GC.stm     [C.cstm|if (ctx->logging) {-    fprintf(stderr, "Compared %s <= %ld: %s.\n", $string:(pretty key), (long)$exp:x', $id:v ? "true" : "false");+    fprintf(ctx->log, "Compared %s <= %ld: %s.\n", $string:(pretty key), (long)$exp:x', $id:v ? "true" : "false");     }|] callKernel (GetSizeMax v size_class) =   let field = "max_" ++ pretty size_class@@ -389,11 +390,11 @@       const size_t $id:local_work_size[$int:kernel_rank] = {$inits:workgroup_dims'};       typename int64_t $id:time_start = 0, $id:time_end = 0;       if (ctx->debugging) {-        fprintf(stderr, "Launching %s with global work size [", $string:(pretty kernel_name));+        fprintf(ctx->log, "Launching %s with global work size [", $string:(pretty kernel_name));         $stms:(printKernelSize global_work_size)-        fprintf(stderr, "] and local work size [");+        fprintf(ctx->log, "] and local work size [");         $stms:(printKernelSize local_work_size)-        fprintf(stderr, "]; local memory parameters sum to %d bytes.\n", (int)$exp:local_bytes);+        fprintf(ctx->log, "]; local memory parameters sum to %d bytes.\n", (int)$exp:local_bytes);         $id:time_start = get_wall_time();       }       OPENCL_SUCCEED_OR_RETURN(@@ -404,7 +405,7 @@         OPENCL_SUCCEED_FATAL(clFinish(ctx->opencl.queue));         $id:time_end = get_wall_time();         long int $id:time_diff = $id:time_end - $id:time_start;-        fprintf(stderr, "kernel %s runtime: %ldus\n",+        fprintf(ctx->log, "kernel %s runtime: %ldus\n",                 $string:(pretty kernel_name), $id:time_diff);       }     }|]@@ -421,7 +422,7 @@      printKernelSize :: VName -> [C.Stm]     printKernelSize work_size =-      intercalate [[C.cstm|fprintf(stderr, ", ");|]] $+      intercalate [[C.cstm|fprintf(ctx->log, ", ");|]] $         map (printKernelDim work_size) [0 .. kernel_rank -1]     printKernelDim global_work_size i =-      [[C.cstm|fprintf(stderr, "%zu", $id:global_work_size[$int:i]);|]]+      [[C.cstm|fprintf(ctx->log, "%zu", $id:global_work_size[$int:i]);|]]

@@ -320,6 +320,7 @@                          int logging;                          typename lock_t lock;                          char *error;+                         typename FILE *log;                          $sdecls:fields                          $sdecls:ctx_opencl_fields                          typename cl_mem global_failure;@@ -342,6 +343,7 @@                      ctx->profiling_paused = 0;                      ctx->logging = cfg->opencl.logging;                      ctx->error = NULL;+                     ctx->log = stderr;                      ctx->opencl.profiling_records_capacity = 200;                      ctx->opencl.profiling_records_used = 0;                      ctx->opencl.profiling_records =@@ -490,16 +492,6 @@                }|]     ) -  GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->-    ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],-      [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                         lock_lock(&ctx->lock);-                         ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(&ctx->opencl));-                         lock_unlock(&ctx->lock);-                         return ctx->error != NULL;-                       }|]-    )-   GC.publicDef_ "context_get_command_queue" GC.InitDecl $ \s ->     ( [C.cedecl|typename cl_command_queue $id:s(struct $id:ctx* ctx);|],       [C.cedecl|typename cl_command_queue $id:s(struct $id:ctx* ctx) {@@ -507,6 +499,11 @@                }|]     ) +  GC.onClear+    [C.citem|if (ctx->error == NULL) {+                        ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(&ctx->opencl));+                      }|]+   GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(&ctx->opencl));|]   mapM_ GC.profileReport $     costCentreReport $@@ -577,7 +574,7 @@   OPENCL_SUCCEED_FATAL(error);   $items:set_args   if (ctx->debugging) {-    fprintf(stderr, "Created kernel %s.\n", $string:(pretty name));+    fprintf(ctx->log, "Created kernel %s.\n", $string:(pretty name));   }   }|]   where

@@ -12,6 +12,7 @@     CParts (..),     asLibrary,     asExecutable,+    asServer,      -- * Pluggable compiler     Operations (..),@@ -58,6 +59,7 @@     publicDef,     publicDef_,     profileReport,+    onClear,     HeaderSection (..),     libDecl,     earlyDecl,@@ -86,8 +88,9 @@ import Data.Loc import qualified Data.Map.Strict as M import Data.Maybe-import Futhark.CodeGen.Backends.GenericC.CLI+import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs) import Futhark.CodeGen.Backends.GenericC.Options+import Futhark.CodeGen.Backends.GenericC.Server (serverDefs) import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode import Futhark.IR.Prop (isBuiltInFunction)@@ -106,6 +109,7 @@     compLibDecls :: DL.DList C.Definition,     compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp),     compProfileItems :: DL.DList C.BlockItem,+    compClearItems :: DL.DList C.BlockItem,     compDeclaredMem :: [(VName, Space)]   } @@ -122,6 +126,7 @@       compLibDecls = mempty,       compCtxFields = mempty,       compProfileItems = mempty,+      compClearItems = mempty,       compDeclaredMem = mempty     } @@ -486,6 +491,10 @@ profileReport x = modify $ \s ->   s {compProfileItems = compProfileItems s <> DL.singleton x} +onClear :: C.BlockItem -> CompilerM op s ()+onClear x = modify $ \s ->+  s {compClearItems = compClearItems s <> DL.singleton x}+ stm :: C.Stm -> CompilerM op s () stm s = item [C.citem|$stm:s|] @@ -604,7 +613,7 @@   if (block->references != NULL) {     *(block->references) -= 1;     if (ctx->detail_memory) {-      fprintf(stderr, "Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n",+      fprintf(ctx->log, "Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n",                       desc, block->desc, $string:spacedesc, *(block->references));     }     if (*(block->references) == 0) {@@ -612,7 +621,7 @@       $items:free       free(block->references);       if (ctx->detail_memory) {-        fprintf(stderr, "%lld bytes freed (now allocated: %lld bytes)\n",+        fprintf(ctx->log, "%lld bytes freed (now allocated: %lld bytes)\n",                 (long long) block->size, (long long) ctx->$id:usagename);       }     }@@ -635,7 +644,7 @@    ctx->$id:usagename += size;   if (ctx->detail_memory) {-    fprintf(stderr, "Allocating %lld bytes for %s in %s (then allocated: %lld bytes)",+    fprintf(ctx->log, "Allocating %lld bytes for %s in %s (then allocated: %lld bytes)",             (long long) size,             desc, $string:spacedesc,             (long long) ctx->$id:usagename);@@ -643,10 +652,10 @@   if (ctx->$id:usagename > ctx->$id:peakname) {     ctx->$id:peakname = ctx->$id:usagename;     if (ctx->detail_memory) {-      fprintf(stderr, " (new peak).\n");+      fprintf(ctx->log, " (new peak).\n");     }   } else if (ctx->detail_memory) {-    fprintf(stderr, ".\n");+    fprintf(ctx->log, ".\n");   }    $items:alloc@@ -670,6 +679,8 @@ } |] +  onClear [C.citem|ctx->$id:peakname = 0;|]+   let peakmsg = "Peak memory usage for " ++ spacedesc ++ ": %lld bytes.\n"   return     ( structdef,@@ -947,6 +958,8 @@ opaqueLibraryFunctions desc vds = do   name <- publicName $ opaqueName desc vds   free_opaque <- publicName $ "free_" ++ opaqueName desc vds+  store_opaque <- publicName $ "store_" ++ opaqueName desc vds+  restore_opaque <- publicName $ "restore_" ++ opaqueName desc vds    let opaque_type = [C.cty|struct $id:name|] @@ -954,23 +967,96 @@         return ()       freeComponent i (ArrayValue _ _ pt signed shape) = do         let rank = length shape+            field = tupleField i         free_array <- publicName $ "free_" ++ arrayName pt signed rank+        -- Protect against NULL here, because we also want to use this+        -- to free partially loaded opaques.         stm-          [C.cstm|if ((tmp = $id:free_array(ctx, obj->$id:(tupleField i))) != 0) {+          [C.cstm|if (obj->$id:field != NULL && (tmp = $id:free_array(ctx, obj->$id:field)) != 0) {                 ret = tmp;              }|] +      storeComponent i (ScalarValue pt sign _) =+        let field = tupleField i+         in ( storageSize pt 0 [C.cexp|NULL|],+              storeValueHeader sign pt 0 [C.cexp|NULL|] [C.cexp|out|]+                ++ [C.cstms|memcpy(out, &obj->$id:field, sizeof(obj->$id:field));+                            out += sizeof(obj->$id:field);|]+            )+      storeComponent i (ArrayValue _ _ pt sign shape) =+        let rank = length shape+            arr_name = arrayName pt sign rank+            field = tupleField i+            shape_array = "futhark_shape_" ++ arr_name+            values_array = "futhark_values_" ++ arr_name+            shape' = [C.cexp|$id:shape_array(ctx, obj->$id:field)|]+            num_elems = cproduct [[C.cexp|$exp:shape'[$int:j]|] | j <- [0 .. rank -1]]+         in ( storageSize pt rank shape',+              storeValueHeader sign pt rank shape' [C.cexp|out|]+                ++ [C.cstms|ret |= $id:values_array(ctx, obj->$id:field, (void*)out);+                            out += $exp:num_elems * sizeof($ty:(primTypeToCType pt));|]+            )+   ctx_ty <- contextType    free_body <- collect $ zipWithM_ freeComponent [0 ..] vds +  store_body <- collect $ do+    let (sizes, stores) = unzip $ zipWith storeComponent [0 ..] vds+        size_vars = map (("size_" ++) . show) [0 .. length sizes -1]+        size_sum = csum [[C.cexp|$id:size|] | size <- size_vars]+    forM_ (zip size_vars sizes) $ \(v, e) ->+      item [C.citem|typename int64_t $id:v = $exp:e;|]+    stm [C.cstm|*n = $exp:size_sum;|]+    stm [C.cstm|if (p != NULL && *p == NULL) { *p = malloc(*n); }|]+    stm [C.cstm|if (p != NULL) { unsigned char *out = *p; $stms:(concat stores) }|]++  let restoreComponent i (ScalarValue pt sign _) = do+        let field = tupleField i+            dataptr = "data_" ++ show i+        stms $ loadValueHeader sign pt 0 [C.cexp|NULL|] [C.cexp|src|]+        item [C.citem|const void* $id:dataptr = src;|]+        stm [C.cstm|src += sizeof(obj->$id:field);|]+        pure [C.cstms|memcpy(&obj->$id:field, $id:dataptr, sizeof(obj->$id:field));|]+      restoreComponent i (ArrayValue _ _ pt sign shape) = do+        let field = tupleField i+            rank = length shape+            arr_name = arrayName pt sign rank+            new_array = "futhark_new_" ++ arr_name+            dataptr = "data_" ++ show i+            shapearr = "shape_" ++ show i+            dims = [[C.cexp|$id:shapearr[$int:j]|] | j <- [0 .. rank -1]]+            num_elems = cproduct dims+        item [C.citem|typename int64_t $id:shapearr[$int:rank];|]+        stms $ loadValueHeader sign pt rank [C.cexp|$id:shapearr|] [C.cexp|src|]+        item [C.citem|const void* $id:dataptr = src;|]+        stm [C.cstm|obj->$id:field = NULL;|]+        stm [C.cstm|src += $exp:num_elems * sizeof($ty:(primTypeToCType pt));|]+        pure+          [C.cstms|+             obj->$id:field = $id:new_array(ctx, $id:dataptr, $args:dims);+             if (obj->$id:field == NULL) { err = 1; }|]++  load_body <- collect $ do+    loads <- concat <$> zipWithM restoreComponent [0 ..] vds+    stm+      [C.cstm|if (err == 0) {+                $stms:loads+              }|]+   headerDecl     (OpaqueDecl desc)     [C.cedecl|int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj);|]+  headerDecl+    (OpaqueDecl desc)+    [C.cedecl|int $id:store_opaque($ty:ctx_ty *ctx, const $ty:opaque_type *obj, void **p, size_t *n);|]+  headerDecl+    (OpaqueDecl desc)+    [C.cedecl|$ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx, const void *p);|]    -- We do not need to enclose the body in a critical section, because-  -- when we free the components of the opaque, we are calling public-  -- API functions that do their own locking.+  -- when we operate on the components of the opaque, we are calling+  -- public API functions that do their own locking.   return     [C.cunit|           int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj) {@@ -979,8 +1065,30 @@             free(obj);             return ret;           }-           |] +          int $id:store_opaque($ty:ctx_ty *ctx,+                               const $ty:opaque_type *obj, void **p, size_t *n) {+            int ret = 0;+            $items:store_body+            return ret;+          }++          $ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx,+                                              const void *p) {+            int err = 0;+            const unsigned char *src = p;+            $ty:opaque_type* obj = malloc(sizeof($ty:opaque_type));+            $items:load_body+            if (err != 0) {+              int ret = 0, tmp;+              $items:free_body+              free(obj);+              obj = NULL;+            }+            return obj;+          }+    |]+ valueDescToCType :: ValueDesc -> CompilerM op s C.Type valueDescToCType (ScalarValue pt signed _) =   return $ signedPrimTypeToCType signed pt@@ -1207,9 +1315,9 @@       let ty' = primTypeToCType ty       decl [C.cdecl|$ty:ty' $id:name;|] --- | The result of compilation to C is four parts, which can be put--- together in various ways.  The obvious way is to concatenate all of--- them, which yields a CLI program.  Another is to compile the+-- | The result of compilation to C is multiple parts, which can be+-- put together in various ways.  The obvious way is to concatenate+-- all of them, which yields a CLI program.  Another is to compile the -- library part by itself, and use the header file to call into it. data CParts = CParts   { cHeader :: String,@@ -1217,9 +1325,21 @@     -- to both CLI and library parts.     cUtils :: String,     cCLI :: String,+    cServer :: String,     cLib :: String   } +gnuSource :: String+gnuSource =+  pretty+    [C.cunit|+// We need to define _GNU_SOURCE before+// _any_ headers files are imported to get+// the usage statistics of a thread (i.e. have RUSAGE_THREAD) on GNU/Linux+// https://manpages.courier-mta.org/htmlman2/getrusage.2.html+$esc:("#define _GNU_SOURCE")+|]+ -- We may generate variables that are never used (e.g. for -- certificates) or functions that are never called (e.g. unused -- intrinsics), and generated code may have other cosmetic issues that@@ -1248,13 +1368,19 @@ asLibrary :: CParts -> (String, String) asLibrary parts =   ( "#pragma once\n\n" <> cHeader parts,-    disableWarnings <> cHeader parts <> cUtils parts <> cLib parts+    gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cLib parts   )  -- | As executable with command-line interface. asExecutable :: CParts -> String-asExecutable (CParts a b c d) = disableWarnings <> a <> b <> c <> d+asExecutable parts =+  gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cCLI parts <> cLib parts +-- | As server executable.+asServer :: CParts -> String+asServer parts =+  gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cServer parts <> cLib parts+ -- | Compile imperative program to a C program.  Always uses the -- function named "main" as entry point, so make sure it is defined. compileProg ::@@ -1275,17 +1401,17 @@   let headerdefs =         [C.cunit| $esc:("// Headers\n")-/* We need to define _GNU_SOURCE before-   _any_ headers files are imported to get-   the usage statistics of a thread (i.e. have RUSAGE_THREAD) on GNU/Linux-   https://manpages.courier-mta.org/htmlman2/getrusage.2.html */-$esc:("#define _GNU_SOURCE") $esc:("#include <stdint.h>") $esc:("#include <stddef.h>") $esc:("#include <stdbool.h>")+$esc:("#include <stdio.h>") $esc:("#include <float.h>") $esc:(header_extra) +$esc:("#ifdef __cplusplus")+$esc:("extern \"C\" {")+$esc:("#endif")+ $esc:("\n// Initialisation\n") $edecls:(initDecls endstate) @@ -1301,6 +1427,10 @@ $esc:("\n// Miscellaneous\n") $edecls:(miscDecls endstate) $esc:("#define FUTHARK_BACKEND_"++backend)++$esc:("#ifdef __cplusplus")+$esc:("}")+$esc:("#endif")                            |]    let utildefs =@@ -1325,12 +1455,12 @@   let early_decls = DL.toList $ compEarlyDecls endstate   let lib_decls = DL.toList $ compLibDecls endstate   let clidefs = cliDefs options $ Functions entry_funs+  let serverdefs = serverDefs options $ Functions entry_funs   let libdefs =         [C.cunit| $esc:("#ifdef _MSC_VER\n#define inline __inline\n#endif") $esc:("#include <string.h>")-$esc:("#include <inttypes.h>")-$esc:("#include <ctype.h>")+$esc:("#include <string.h>") $esc:("#include <errno.h>") $esc:("#include <assert.h>") @@ -1355,7 +1485,14 @@ $edecls:entry_point_decls   |] -  return $ CParts (pretty headerdefs) (pretty utildefs) (pretty clidefs) (pretty libdefs)+  return $+    CParts+      { cHeader = pretty headerdefs,+        cUtils = pretty utildefs,+        cCLI = pretty clidefs,+        cServer = pretty serverdefs,+        cLib = pretty libdefs+      }   where     Definitions consts (Functions funs) = prog     entry_funs = filter (functionEntry . snd) funs@@ -1400,6 +1537,7 @@ commonLibFuns :: [C.BlockItem] -> CompilerM op s () commonLibFuns memreport = do   ctx <- contextType+  ops <- asks envOperations   profilereport <- gets $ DL.toList . compProfileItems    publicDef_ "context_report" MiscDecl $ \s ->@@ -1407,7 +1545,7 @@       [C.cedecl|char* $id:s($ty:ctx *ctx) {                  struct str_builder builder;                  str_builder_init(&builder);-                 if (ctx->detail_memory || ctx->profiling) {+                 if (ctx->detail_memory || ctx->profiling || ctx->logging) {                    $items:memreport                  }                  if (ctx->profiling) {@@ -1426,6 +1564,13 @@                        }|]     ) +  publicDef_ "context_set_logging_file" MiscDecl $ \s ->+    ( [C.cedecl|void $id:s($ty:ctx* ctx, typename FILE* f);|],+      [C.cedecl|void $id:s($ty:ctx* ctx, typename FILE* f) {+                  ctx->log = f;+                }|]+    )+   publicDef_ "context_pause_profiling" MiscDecl $ \s ->     ( [C.cedecl|void $id:s($ty:ctx* ctx);|],       [C.cedecl|void $id:s($ty:ctx* ctx) {@@ -1440,6 +1585,15 @@                }|]     ) +  clears <- gets $ DL.toList . compClearItems+  publicDef_ "context_clear_caches" MiscDecl $ \s ->+    ( [C.cedecl|int $id:s($ty:ctx* ctx);|],+      [C.cedecl|int $id:s($ty:ctx* ctx) {+                         $items:(criticalSection ops clears)+                         return ctx->error != NULL;+                       }|]+    )+ compileConstants :: Constants op -> CompilerM op s [C.BlockItem] compileConstants (Constants ps init_consts) = do   ctx_ty <- contextType@@ -1752,7 +1906,7 @@   e' <- compileExp e   stm     [C.cstm|if (ctx->debugging) {-          fprintf(stderr, $string:fmtstr, $exp:s, ($ty:ety)$exp:e', '\n');+          fprintf(ctx->log, $string:fmtstr, $exp:s, ($ty:ety)$exp:e', '\n');        }|]   where     (fmt, ety) = case primExpType e of@@ -1763,7 +1917,7 @@ compileCode (DebugPrint s Nothing) =   stm     [C.cstm|if (ctx->debugging) {-          fprintf(stderr, "%s\n", $exp:s);+          fprintf(ctx->log, "%s\n", $exp:s);        }|] compileCode c   | Just (name, vol, t, e, c') <- declareAndSet c = do

@@ -6,6 +6,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TupleSections #-} +-- | Code generation for standalone executables. module Futhark.CodeGen.Backends.GenericC.CLI   ( cliDefs,   )@@ -362,6 +363,8 @@       )  {-# NOINLINE cliDefs #-}++-- | Generate Futhark standalone executable code. cliDefs :: [Option] -> Functions a -> [C.Definition] cliDefs options (Functions funs) =   let values_h = $(embedStringFile "rts/c/values.h")@@ -372,12 +375,9 @@       (cli_entry_point_decls, entry_point_inits) =         unzip $ map (uncurry cliEntryPoint) funs    in [C.cunit|-$esc:("#include <string.h>")-$esc:("#include <inttypes.h>")-$esc:("#include <errno.h>")-$esc:("#include <ctype.h>")-$esc:("#include <errno.h>") $esc:("#include <getopt.h>")+$esc:("#include <ctype.h>")+$esc:("#include <inttypes.h>")  $esc:values_h @@ -404,10 +404,6 @@ int main(int argc, char** argv) {   fut_progname = argv[0]; -  struct entry_point_entry entry_points[] = {-    $inits:entry_point_inits-  };-   struct futhark_context_config *cfg = futhark_context_config_new();   assert(cfg != NULL); @@ -426,6 +422,10 @@   if (error != NULL) {     futhark_panic(1, "%s", error);   }++  struct entry_point_entry entry_points[] = {+    $inits:entry_point_inits+  };    if (entry_point != NULL) {     int num_entry_points = sizeof(entry_points) / sizeof(entry_points[0]);

@@ -0,0 +1,282 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TupleSections #-}++-- | Code generation for server executables.+module Futhark.CodeGen.Backends.GenericC.Server+  ( serverDefs,+  )+where++import Data.Bifunctor (first, second)+import Data.FileEmbed+import qualified Data.Map as M+import Futhark.CodeGen.Backends.GenericC.Options+import Futhark.CodeGen.Backends.SimpleRep+import Futhark.CodeGen.ImpCode+import qualified Language.C.Quote.OpenCL as C+import qualified Language.C.Syntax as C++genericOptions :: [Option]+genericOptions =+  [ Option+      { optionLongName = "debugging",+        optionShortName = Just 'D',+        optionArgument = NoArgument,+        optionDescription = "Perform possibly expensive internal correctness checks and verbose logging.",+        optionAction = [C.cstm|futhark_context_config_set_debugging(cfg, 1);|]+      },+    Option+      { optionLongName = "log",+        optionShortName = Just 'L',+        optionArgument = NoArgument,+        optionDescription = "Print various low-overhead logging information while running.",+        optionAction = [C.cstm|futhark_context_config_set_logging(cfg, 1);|]+      },+    Option+      { optionLongName = "help",+        optionShortName = Just 'h',+        optionArgument = NoArgument,+        optionDescription = "Print help information and exit.",+        optionAction =+          [C.cstm|{+                   printf("Usage: %s [OPTION]...\nOptions:\n\n%s\nFor more information, consult the Futhark User's Guide or the man pages.\n",+                          fut_progname, option_descriptions);+                   exit(0);+                  }|]+      }+  ]++typeStructName :: ExternalValue -> String+typeStructName (TransparentValue (ScalarValue pt signed _)) =+  let name = prettySigned (signed == TypeUnsigned) pt+   in "type_" ++ name+typeStructName (TransparentValue (ArrayValue _ _ pt signed shape)) =+  let rank = length shape+      name = arrayName pt signed rank+   in "type_" ++ name+typeStructName (OpaqueValue name vds) =+  "type_" ++ opaqueName name vds++valueDescBoilerplate :: ExternalValue -> (String, (C.Initializer, [C.Definition]))+valueDescBoilerplate ev@(TransparentValue (ScalarValue pt signed _)) =+  let name = prettySigned (signed == TypeUnsigned) pt+      type_name = typeStructName ev+   in (name, ([C.cinit|&$id:type_name|], mempty))+valueDescBoilerplate ev@(TransparentValue (ArrayValue _ _ pt signed shape)) =+  let rank = length shape+      name = arrayName pt signed rank+      pt_name = prettySigned (signed == TypeUnsigned) pt+      pretty_name = concat (replicate rank "[]") ++ pt_name+      type_name = typeStructName ev+      aux_name = type_name ++ "_aux"+      info_name = pt_name ++ "_info"+      array_new = "futhark_new_" ++ name+      array_new_wrap = "futhark_new_" ++ name ++ "_wrap"+      array_free = "futhark_free_" ++ name+      array_shape = "futhark_shape_" ++ name+      array_values = "futhark_values_" ++ name+      shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank -1]]+   in ( name,+        ( [C.cinit|&$id:type_name|],+          [C.cunit|+              void* $id:array_new_wrap(struct futhark_context *ctx,+                                       const void* p,+                                       const typename int64_t* shape) {+                return $id:array_new(ctx, p, $args:shape_args);+              }+              struct array_aux $id:aux_name = {+                .name = $string:pretty_name,+                .rank = $int:rank,+                .info = &$id:info_name,+                .new = (typename array_new_fn)$id:array_new_wrap,+                .free = (typename array_free_fn)$id:array_free,+                .shape = (typename array_shape_fn)$id:array_shape,+                .values = (typename array_values_fn)$id:array_values+              };+              struct type $id:type_name = {+                .name = $string:pretty_name,+                .restore = (typename restore_fn)restore_array,+                .store = (typename store_fn)store_array,+                .free = (typename free_fn)free_array,+                .aux = &$id:aux_name+              };|]+        )+      )+valueDescBoilerplate ev@(OpaqueValue name vds) =+  let type_name = typeStructName ev+      aux_name = type_name ++ "_aux"+      opaque_free = "futhark_free_" ++ opaqueName name vds+      opaque_store = "futhark_store_" ++ opaqueName name vds+      opaque_restore = "futhark_restore_" ++ opaqueName name vds+   in ( name,+        ( [C.cinit|&$id:type_name|],+          [C.cunit|+              struct opaque_aux $id:aux_name = {+                .free = (typename opaque_free_fn)$id:opaque_free+              };+              struct type $id:type_name = {+                .name = $string:name,+                .restore = (typename restore_fn)$id:opaque_store,+                .store = (typename store_fn)$id:opaque_restore,+                .free = (typename free_fn)free_opaque,+                .aux = &$id:aux_name+              };|]+        )+      )++functionExternalValues :: Function a -> [ExternalValue]+functionExternalValues fun = functionResult fun ++ functionArgs fun++entryTypeBoilerplate :: Functions a -> ([C.Initializer], [C.Definition])+entryTypeBoilerplate (Functions funs) =+  second concat $+    unzip $+      M.elems $+        M.fromList $+          map valueDescBoilerplate $+            concatMap (functionExternalValues . snd) $+              filter (functionEntry . snd) funs++oneEntryBoilerplate :: (Name, Function a) -> ([C.Definition], C.Initializer)+oneEntryBoilerplate (name, fun) =+  let entry_f = "futhark_entry_" ++ pretty name+      call_f = "call_" ++ pretty name+      out_types = functionResult fun+      in_types = functionArgs fun+      out_types_name = pretty name ++ "_out_types"+      in_types_name = pretty name ++ "_in_types"+      (out_items, out_args)+        | null out_types = ([C.citems|(void)outs;|], mempty)+        | otherwise = unzip $ zipWith loadOut [0 ..] out_types+      (in_items, in_args)+        | null in_types = ([C.citems|(void)ins;|], mempty)+        | otherwise = unzip $ zipWith loadIn [0 ..] in_types+   in ( [C.cunit|+                struct type* $id:out_types_name[] = {+                  $inits:(map typeStructInit out_types),+                  NULL+                };+                struct type* $id:in_types_name[] = {+                  $inits:(map typeStructInit in_types),+                  NULL+                };+                int $id:call_f(struct futhark_context *ctx, void **outs, void **ins) {+                  $items:out_items+                  $items:in_items+                  return $id:entry_f(ctx, $args:out_args, $args:in_args);+                }+                |],+        [C.cinit|{+            .name = $string:(pretty name),+            .f = $id:call_f,+            .in_types = $id:in_types_name,+            .out_types = $id:out_types_name+            }|]+      )+  where+    typeStructInit t = [C.cinit|&$id:(typeStructName t)|]++    loadOut i ev =+      let v = "out" ++ show (i :: Int)+       in ( [C.citem|$ty:(externalValueType ev) *$id:v = outs[$int:i];|],+            [C.cexp|$id:v|]+          )+    loadIn i ev =+      let v = "in" ++ show (i :: Int)+          evt = externalValueType ev+       in ( [C.citem|$ty:evt $id:v = *($ty:evt*)ins[$int:i];|],+            [C.cexp|$id:v|]+          )++entryBoilerplate :: Functions a -> ([C.Definition], [C.Initializer])+entryBoilerplate (Functions funs) =+  first concat $ unzip $ map oneEntryBoilerplate $ filter (functionEntry . snd) funs++mkBoilerplate ::+  Functions a ->+  ([C.Definition], [C.Initializer], [C.Initializer])+mkBoilerplate funs =+  let (type_inits, type_defs) = entryTypeBoilerplate funs+      (entry_defs, entry_inits) = entryBoilerplate funs+   in (type_defs ++ entry_defs, type_inits, entry_inits)++{-# NOINLINE serverDefs #-}++-- | Generate Futhark server executable code.+serverDefs :: [Option] -> Functions a -> [C.Definition]+serverDefs options funs =+  let server_h = $(embedStringFile "rts/c/server.h")+      values_h = $(embedStringFile "rts/c/values.h")+      tuning_h = $(embedStringFile "rts/c/tuning.h")+      option_parser =+        generateOptionParser "parse_options" $ genericOptions ++ options+      (boilerplate_defs, type_inits, entry_point_inits) =+        mkBoilerplate funs+   in [C.cunit|+$esc:("#include <getopt.h>")+$esc:("#include <ctype.h>")+$esc:("#include <inttypes.h>")++// If the entry point is NULL, the program will terminate after doing initialisation and such.  It is not used for anything else in server mode.+static const char *entry_point = "main";++$esc:values_h+$esc:server_h+$esc:tuning_h++$edecls:boilerplate_defs++struct type* types[] = {+  $inits:type_inits,+  NULL+};++struct entry_point entry_points[] = {+  $inits:entry_point_inits,+  { .name = NULL }+};++struct futhark_prog prog = {+  .types = types,+  .entry_points = entry_points+};++$func:option_parser++int main(int argc, char** argv) {+  fut_progname = argv[0];++  struct futhark_context_config *cfg = futhark_context_config_new();+  assert(cfg != NULL);++  int parsed_options = parse_options(cfg, argc, argv);+  argc -= parsed_options;+  argv += parsed_options;++  if (argc != 0) {+    futhark_panic(1, "Excess non-option: %s\n", argv[0]);+  }++  struct futhark_context *ctx = futhark_context_new(cfg);+  assert (ctx != NULL);++  futhark_context_set_logging_file(ctx, stdout);++  char* error = futhark_context_get_error(ctx);+  if (error != NULL) {+    futhark_panic(1, "Error during context initialisation:\n%s", error);+  }++  if (entry_point != NULL) {+    run_server(&prog, ctx);+  }++  futhark_context_free(ctx);+  futhark_context_config_free(cfg);+}+|]

@@ -8,6 +8,7 @@ -- sequential and PyOpenCL Python code. module Futhark.CodeGen.Backends.GenericPython   ( compileProg,+    CompilerMode,     Constructor (..),     emptyConstructor,     compileName,@@ -52,6 +53,7 @@ import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.CodeGen.Backends.GenericPython.Options import qualified Futhark.CodeGen.ImpCode as Imp+import Futhark.Compiler.CLI (CompilerMode (..)) import Futhark.IR.Primitive hiding (Bool) import Futhark.IR.Prop (isBuiltInFunction, subExpVars) import Futhark.IR.Syntax (Space (..))@@ -266,48 +268,59 @@ standardOptions :: [Option] standardOptions =   [ Option-      { optionLongName = "write-runtime-to",-        optionShortName = Just 't',-        optionArgument = RequiredArgument "str",-        optionAction =-          [ If-              (Var "runtime_file")-              [Exp $ simpleCall "runtime_file.close" []]-              [],-            Assign (Var "runtime_file") $-              simpleCall "open" [Var "optarg", String "w"]-          ]-      },-    Option-      { optionLongName = "runs",-        optionShortName = Just 'r',-        optionArgument = RequiredArgument "str",-        optionAction =-          [ Assign (Var "num_runs") $ Var "optarg",-            Assign (Var "do_warmup_run") $ Bool True-          ]-      },-    Option-      { optionLongName = "entry-point",-        optionShortName = Just 'e',-        optionArgument = RequiredArgument "str",-        optionAction =-          [Assign (Var "entry_point") $ Var "optarg"]-      },-    Option-      { optionLongName = "binary-output",-        optionShortName = Just 'b',-        optionArgument = NoArgument,-        optionAction = [Assign (Var "binary_output") $ Bool True]-      },-    Option       { optionLongName = "tuning",         optionShortName = Nothing,         optionArgument = RequiredArgument "open",         optionAction = [Exp $ simpleCall "read_tuning_file" [Var "sizes", Var "optarg"]]+      },+    Option+      { optionLongName = "log",+        optionShortName = Just 'L',+        optionArgument = NoArgument,+        optionAction = [Pass]       }   ] +executableOptions :: [Option]+executableOptions =+  standardOptions+    ++ [ Option+           { optionLongName = "write-runtime-to",+             optionShortName = Just 't',+             optionArgument = RequiredArgument "str",+             optionAction =+               [ If+                   (Var "runtime_file")+                   [Exp $ simpleCall "runtime_file.close" []]+                   [],+                 Assign (Var "runtime_file") $+                   simpleCall "open" [Var "optarg", String "w"]+               ]+           },+         Option+           { optionLongName = "runs",+             optionShortName = Just 'r',+             optionArgument = RequiredArgument "str",+             optionAction =+               [ Assign (Var "num_runs") $ Var "optarg",+                 Assign (Var "do_warmup_run") $ Bool True+               ]+           },+         Option+           { optionLongName = "entry-point",+             optionShortName = Just 'e',+             optionArgument = RequiredArgument "str",+             optionAction =+               [Assign (Var "entry_point") $ Var "optarg"]+           },+         Option+           { optionLongName = "binary-output",+             optionShortName = Just 'b',+             optionArgument = NoArgument,+             optionAction = [Assign (Var "binary_output") $ Bool True]+           }+       ]+ -- | The class generated by the code generator must have a -- constructor, although it can be vacuous. data Constructor = Constructor [String] [PyStmt]@@ -322,7 +335,8 @@  compileProg ::   MonadFreshNames m =>-  Maybe String ->+  CompilerMode ->+  String ->   Constructor ->   [PyStmt] ->   [PyStmt] ->@@ -332,13 +346,13 @@   [Option] ->   Imp.Definitions op ->   m String-compileProg module_name constructor imports defines ops userstate sync options prog = do+compileProg mode class_name constructor imports defines ops userstate sync options prog = do   src <- getNameSource   let prog' = runCompilerM ops src userstate compileProg'       maybe_shebang =-        case module_name of-          Nothing -> "#!/usr/bin/env python\n"-          Just _ -> ""+        case mode of+          ToLibrary -> ""+          _ -> "#!/usr/bin/env python3\n"   return $     maybe_shebang       ++ pretty@@ -348,7 +362,13 @@                    Assign (Var "sizes") $ Dict []                  ]               ++ defines-              ++ [Escape pyUtility]+              ++ [ Escape pyValues,+                   Escape pyFunctions,+                   Escape pyPanic,+                   Escape pyTuning,+                   Escape pyUtility,+                   Escape pyServer+                 ]               ++ prog'         )   where@@ -361,41 +381,64 @@        let constructor' = constructorToFunDef constructor at_inits -      case module_name of-        Just name -> do+      case mode of+        ToLibrary -> do           (entry_points, entry_point_types) <--            unzip <$> mapM (compileEntryFun sync) (filter (Imp.functionEntry . snd) funs)+            unzip+              <$> mapM+                (compileEntryFun sync DoNotReturnTiming)+                (filter (Imp.functionEntry . snd) funs)           return             [ ClassDef $-                Class name $+                Class class_name $                   Assign (Var "entry_points") (Dict entry_point_types) :                   map FunDef (constructor' : definitions ++ entry_points)             ]-        Nothing -> do-          let classinst = Assign (Var "self") $ simpleCall "internal" []+        ToServer -> do+          (entry_points, entry_point_types) <-+            unzip+              <$> mapM+                (compileEntryFun sync ReturnTiming)+                (filter (Imp.functionEntry . snd) funs)+          return $+            parse_options_server+              ++ [ ClassDef+                     ( Class class_name $+                         Assign (Var "entry_points") (Dict entry_point_types) :+                         map FunDef (constructor' : definitions ++ entry_points)+                     ),+                   Assign+                     (Var "server")+                     (simpleCall "Server" [simpleCall class_name []]),+                   Exp $ simpleCall "server.run" []+                 ]+        ToExecutable -> do+          let classinst = Assign (Var "self") $ simpleCall class_name []           (entry_point_defs, entry_point_names, entry_points) <-             unzip3               <$> mapM                 (callEntryFun sync)                 (filter (Imp.functionEntry . snd) funs)-          return-            ( parse_options-                ++ ClassDef-                  ( Class "internal" $-                      map FunDef $-                        constructor' : definitions-                  ) :-              classinst :-              map FunDef entry_point_defs-                ++ selectEntryPoint entry_point_names entry_points-            )+          return $+            parse_options_executable+              ++ ClassDef+                ( Class class_name $+                    map FunDef $+                      constructor' : definitions+                ) :+            classinst :+            map FunDef entry_point_defs+              ++ selectEntryPoint entry_point_names entry_points -    parse_options =+    parse_options_executable =       Assign (Var "runtime_file") None :       Assign (Var "do_warmup_run") (Bool False) :       Assign (Var "num_runs") (Integer 1) :       Assign (Var "entry_point") (String "main") :       Assign (Var "binary_output") (Bool False) :+      generateOptionParser (executableOptions ++ options)++    parse_options_server =       generateOptionParser (standardOptions ++ options)      selectEntryPoint entry_point_names entry_points =@@ -817,17 +860,44 @@           [srcmem, srcidx, Var "ct.c_byte"]   stm $ Exp $ simpleCall "ct.memmove" [offset_call1, offset_call2, nbytes] +data ReturnTiming = ReturnTiming | DoNotReturnTiming+ compileEntryFun ::   [PyStmt] ->+  ReturnTiming ->   (Name, Imp.Function op) ->   CompilerM op s (PyFunDef, (PyExp, PyExp))-compileEntryFun sync entry = do+compileEntryFun sync timing entry = do   (fname', params, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry-  let ret = Return $ tupleOrSingle $ map snd res+  let (maybe_sync, ret) =+        case timing of+          DoNotReturnTiming ->+            ( [],+              Return $ tupleOrSingle $ map snd res+            )+          ReturnTiming ->+            ( sync,+              Return $+                Tuple+                  [ Var "runtime",+                    tupleOrSingle $ map snd res+                  ]+            )       (pts, rts) = entryTypes $ snd entry++      do_run =+        Assign (Var "time_start") (simpleCall "time.time" []) :+        body_lib ++ maybe_sync+          ++ [ Assign (Var "runtime") $+                 BinOp+                   "-"+                   (toMicroseconds (simpleCall "time.time" []))+                   (toMicroseconds (Var "time_start"))+             ]+   return     ( Def fname' ("self" : params) $-        prepareIn ++ body_lib ++ prepareOut ++ sync ++ [ret],+        prepareIn ++ do_run ++ prepareOut ++ sync ++ [ret],       (String fname', Tuple [List (map String pts), List (map String rts)])     ) @@ -905,8 +975,10 @@         Exp $ simpleCall "runtime_file.write" [String "\n"],         Exp $ simpleCall "runtime_file.flush" []       ]-    toMicroseconds x =-      simpleCall "int" [BinOp "*" x $ Integer 1000000]++toMicroseconds :: PyExp -> PyExp+toMicroseconds x =+  simpleCall "int" [BinOp "*" x $ Integer 1000000]  compileUnOp :: Imp.UnOp -> String compileUnOp op =

@@ -6,6 +6,7 @@     pyValues,     pyPanic,     pyTuning,+    pyServer,   ) where @@ -25,3 +26,6 @@  pyTuning :: String pyTuning = $(embedStringFile "rts/python/tuning.py")++pyServer :: String+pyServer = $(embedStringFile "rts/python/server.py")

@@ -9,6 +9,7 @@     GC.CParts (..),     GC.asLibrary,     GC.asExecutable,+    GC.asServer,   ) where @@ -26,6 +27,7 @@ import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C +-- | Compile the program to ImpCode with multicore operations. compileProg ::   MonadFreshNames m =>   Prog MCMem ->@@ -114,8 +116,10 @@                           int debugging;                           int profiling;                           int profiling_paused;+                          int logging;                           typename lock_t lock;                           char *error;+                          typename FILE *log;                           int total_runs;                           long int total_runtime;                           $sdecls:fields@@ -140,7 +144,9 @@                  ctx->debugging = cfg->debugging;                  ctx->profiling = cfg->profiling;                  ctx->profiling_paused = 0;+                 ctx->logging = 0;                  ctx->error = NULL;+                 ctx->log = stderr;                  create_lock(&ctx->lock);                   int tune_kappa = 0;@@ -356,7 +362,7 @@             then               [ [C.citem|                      for (int i = 0; i < ctx->scheduler.num_threads; i++) {-                       fprintf(stderr,+                       fprintf(ctx->log,                          $string:(format_string name is_array),                          i,                          ctx->$id:runs[i],@@ -371,7 +377,7 @@               ]             else               [ [C.citem|-                    fprintf(stderr,+                    fprintf(ctx->log,                        $string:(format_string name is_array),                        ctx->$id:runs,                        (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1),

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} +-- | Code generation for Python with OpenCL. module Futhark.CodeGen.Backends.PyOpenCL   ( compileProg,   )@@ -10,7 +11,6 @@ import qualified Data.Map as M import qualified Futhark.CodeGen.Backends.GenericPython as Py import Futhark.CodeGen.Backends.GenericPython.AST-import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.PyOpenCL.Boilerplate import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp@@ -19,13 +19,14 @@ import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) ---maybe pass the config file rather than multiple arguments+-- | Compile the program to Python with calls to OpenCL. compileProg ::   MonadFreshNames m =>-  Maybe String ->+  Py.CompilerMode ->+  String ->   Prog KernelsMem ->   m (ImpGen.Warnings, String)-compileProg module_name prog = do+compileProg mode class_name prog = do   ( ws,     Imp.Program       opencl_code@@ -57,11 +58,7 @@           Assign (Var "default_group_size") None,           Assign (Var "default_num_groups") None,           Assign (Var "default_tile_size") None,-          Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude ++ opencl_code,-          Escape pyValues,-          Escape pyFunctions,-          Escape pyPanic,-          Escape pyTuning+          Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude ++ opencl_code         ]    let imports =@@ -152,7 +149,8 @@    (ws,)     <$> Py.compileProg-      module_name+      mode+      class_name       constructor       imports       defines

@@ -8,6 +8,7 @@     GC.CParts (..),     GC.asLibrary,     GC.asExecutable,+    GC.asServer,   ) where @@ -80,8 +81,10 @@                           int detail_memory;                           int debugging;                           int profiling;+                          int logging;                           typename lock_t lock;                           char *error;+                          typename FILE *log;                           int profiling_paused;                           $sdecls:fields                         };|]@@ -97,7 +100,9 @@                                   ctx->detail_memory = cfg->debugging;                                   ctx->debugging = cfg->debugging;                                   ctx->profiling = cfg->debugging;+                                  ctx->logging = cfg->debugging;                                   ctx->error = NULL;+                                  ctx->log = stderr;                                   create_lock(&ctx->lock);                                   $stms:init_fields                                   init_constants(ctx);@@ -115,14 +120,6 @@         )        GC.publicDef_ "context_sync" GC.MiscDecl $ \s ->-        ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],-          [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                                 (void)ctx;-                                 return 0;-                               }|]-        )--      GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->         ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],           [C.cedecl|int $id:s(struct $id:ctx* ctx) {                                  (void)ctx;

@@ -1,3 +1,4 @@+-- | Code generation for sequential Python. module Futhark.CodeGen.Backends.SequentialPython   ( compileProg,   )@@ -6,22 +7,24 @@ import Control.Monad import qualified Futhark.CodeGen.Backends.GenericPython as GenericPython import Futhark.CodeGen.Backends.GenericPython.AST-import Futhark.CodeGen.Backends.GenericPython.Definitions import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen import Futhark.IR.SeqMem import Futhark.MonadFreshNames +-- | Compile the program to Python. compileProg ::   MonadFreshNames m =>-  Maybe String ->+  GenericPython.CompilerMode ->+  String ->   Prog SeqMem ->   m (ImpGen.Warnings, String)-compileProg module_name =+compileProg mode class_name =   ImpGen.compileProg     >=> traverse       ( GenericPython.compileProg-          module_name+          mode+          class_name           GenericPython.emptyConstructor           imports           defines@@ -37,7 +40,7 @@         Import "ctypes" $ Just "ct",         Import "time" Nothing       ]-    defines = [Escape pyValues, Escape pyFunctions, Escape pyPanic, Escape pyTuning]+    defines = []     operations :: GenericPython.Operations Imp.Sequential ()     operations =       GenericPython.defaultOperations

@@ -12,7 +12,9 @@     signedPrimTypeToCType,     arrayName,     opaqueName,+    externalValueType,     cproduct,+    csum,      -- * Primitive value operations     cIntOps,@@ -21,6 +23,11 @@     cFloat64Ops,     cFloat64Funs,     cFloatConvOps,++    -- * Storing/restoring values in byte sequences+    storageSize,+    storeValueHeader,+    loadValueHeader,   ) where @@ -117,6 +124,16 @@           )     iter x = ((x :: Word32) `shiftR` 16) `xor` x +-- | The type used to expose a Futhark value in the C API.  A pointer+-- in the case of arrays and opaques.+externalValueType :: ExternalValue -> C.Type+externalValueType (OpaqueValue desc vds) =+  [C.cty|struct $id:("futhark_" ++ opaqueName desc vds)*|]+externalValueType (TransparentValue (ArrayValue _ _ pt signed shape)) =+  [C.cty|struct $id:("futhark_" ++ arrayName pt signed (length shape))*|]+externalValueType (TransparentValue (ScalarValue pt signed _)) =+  signedPrimTypeToCType signed pt+ -- | Return an expression multiplying together the given expressions. -- If an empty list is given, the expression @1@ is returned. cproduct :: [C.Exp] -> C.Exp@@ -125,6 +142,14 @@   where     mult x y = [C.cexp|$exp:x * $exp:y|] +-- | Return an expression summing the given expressions.+-- If an empty list is given, the expression @0@ is returned.+csum :: [C.Exp] -> C.Exp+csum [] = [C.cexp|0|]+csum (e : es) = foldl mult e es+  where+    mult x y = [C.cexp|$exp:x + $exp:y|]+ instance C.ToIdent Name where   toIdent = C.toIdent . zEncodeString . nameToString @@ -953,3 +978,65 @@     } $esc:("#endif") |]++storageSize :: PrimType -> Int -> C.Exp -> C.Exp+storageSize pt rank shape =+  [C.cexp|$int:header_size ++          $int:rank * sizeof(typename int64_t) ++          $exp:(cproduct dims) * $int:pt_size|]+  where+    header_size, pt_size :: Int+    header_size = 1 + 1 + 1 + 4 -- 'b' <version> <num_dims> <type>+    pt_size = primByteSize pt+    dims = [[C.cexp|$exp:shape[$int:i]|] | i <- [0 .. rank -1]]++typeStr :: Signedness -> PrimType -> String+typeStr sign pt =+  case (sign, pt) of+    (_, Bool) -> "bool"+    (_, Cert) -> "bool"+    (_, FloatType Float32) -> " f32"+    (_, FloatType Float64) -> " f64"+    (TypeDirect, IntType Int8) -> "  i8"+    (TypeDirect, IntType Int16) -> " i16"+    (TypeDirect, IntType Int32) -> " i32"+    (TypeDirect, IntType Int64) -> " i64"+    (TypeUnsigned, IntType Int8) -> "  u8"+    (TypeUnsigned, IntType Int16) -> " u16"+    (TypeUnsigned, IntType Int32) -> " u32"+    (TypeUnsigned, IntType Int64) -> " u64"++storeValueHeader :: Signedness -> PrimType -> Int -> C.Exp -> C.Exp -> [C.Stm]+storeValueHeader sign pt rank shape dest =+  [C.cstms|+          *$exp:dest++ = 'b';+          *$exp:dest++ = 1;+          *$exp:dest++ = $int:rank;+          memcpy($exp:dest, $string:(typeStr sign pt), 4);+          $exp:dest += 4;+          $stms:copy_shape+          |]+  where+    copy_shape+      | rank == 0 = []+      | otherwise =+        [C.cstms|+                memcpy($exp:dest, $exp:shape, $int:rank*sizeof(typename int64_t));+                $exp:dest += $int:rank*sizeof(typename int64_t);|]++loadValueHeader :: Signedness -> PrimType -> Int -> C.Exp -> C.Exp -> [C.Stm]+loadValueHeader sign pt rank shape src =+  [C.cstms|+     err |= (*$exp:src++ != 'b');+     err |= (*$exp:src++ != 1);+     err |= (*$exp:src++ != $exp:rank);+     err |= (memcmp($exp:src, $string:(typeStr sign pt), 4) != 0);+     $exp:src += 4;+     if (err == 0) {+       $stms:load_shape+       $exp:src += $int:rank*sizeof(typename int64_t);+     }|]+  where+    load_shape+      | rank == 0 = []+      | otherwise = [C.cstms|memcpy($exp:shape, src, $int:rank*sizeof(typename int64_t));|]

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-} {-# LANGUAGE TupleSections #-} @@ -133,9 +132,8 @@  -- | A description of an externally meaningful value. data ValueDesc-  = -- | An array with memory block, memory block size,-    -- memory space, element type, signedness of element-    -- type (if applicable), and shape.+  = -- | An array with memory block memory space, element type,+    -- signedness of element type (if applicable), and shape.     ArrayValue VName Space PrimType Signedness [DimSize]   | -- | A scalar value with signedness if applicable.     ScalarValue PrimType Signedness VName@@ -601,6 +599,8 @@   traverse _ (DebugPrint s v) =     pure $ DebugPrint s v +-- | The names declared with 'DeclareMem', 'DeclareScalar', and+-- 'DeclareArray' in the given code. declaredIn :: Code a -> Names declaredIn (DeclareMem name _) = oneName name declaredIn (DeclareScalar name _ _) = oneName name

@@ -1567,7 +1567,7 @@   error $ "compileAlloc: Invalid pattern: " ++ pretty pat  -- | The number of bytes needed to represent the array in a--- straightforward contiguous format, as an 'Int64' expression.+-- straightforward contiguous format, as an t'Int64' expression. typeSize :: Type -> Count Bytes (Imp.TExp Int64) typeSize t =   Imp.bytes $

@@ -1,3 +1,4 @@+-- | Code generation for ImpCode with CUDA kernels. module Futhark.CodeGen.ImpGen.CUDA   ( compileProg,     Warnings,@@ -11,5 +12,6 @@ import Futhark.IR.KernelsMem import Futhark.MonadFreshNames +-- | Compile the program to ImpCode with CUDA kernels. compileProg :: MonadFreshNames m => Prog KernelsMem -> m (Warnings, Program) compileProg prog = second kernelsToCUDA <$> compileProgCUDA prog

@@ -71,7 +71,7 @@ -- | Code generation for the body of the SegRed, taking a continuation -- for saving the results of the body.  The results should be -- represented as a pairing of a t'SubExp' along with a list of--- indexes into that 'SubExp' for reading the result.+-- indexes into that t'SubExp' for reading the result. type DoSegBody = ([(SubExp, [Imp.TExp Int64])] -> InKernelGen ()) -> InKernelGen ()  -- | Compile 'SegRed' instance to host-level code with calls to

@@ -1,3 +1,6 @@+-- | Code generation for 'SegScan'.  Dispatches to either a+-- single-pass or two-pass implementation, depending on the nature of+-- the scan and the chosen abckend. module Futhark.CodeGen.ImpGen.Kernels.SegScan (compileSegScan) where  import qualified Futhark.CodeGen.ImpCode.Kernels as Imp

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +-- | Code generation for ImpCode with multicore operations. module Futhark.CodeGen.ImpGen.Multicore   ( Futhark.CodeGen.ImpGen.Multicore.compileProg,     Warnings,

@@ -170,8 +170,8 @@     else Imp.Dynamic  -- | Try to extract invariant allocations.  If we assume that the--- given 'Code' is the body of a 'SegOp', then it is always safe to--- move the immediate allocations to the prebody.+-- given 'Imp.Code' is the body of a 'SegOp', then it is always safe+-- to move the immediate allocations to the prebody. extractAllocations :: Imp.Code -> (Imp.Code, Imp.Code) extractAllocations segop_code = f segop_code   where

@@ -1,3 +1,4 @@+-- | Multicore code generation for 'SegMap'. module Futhark.CodeGen.ImpGen.Multicore.SegMap   ( compileSegMap,   )

@@ -1,3 +1,4 @@+-- | Code generation for ImpCode with OpenCL kernels. module Futhark.CodeGen.ImpGen.OpenCL   ( compileProg,     Warnings,@@ -11,5 +12,6 @@ import Futhark.IR.KernelsMem import Futhark.MonadFreshNames +-- | Compile the program to ImpCode with OpenCL kernels. compileProg :: MonadFreshNames m => Prog KernelsMem -> m (Warnings, OpenCL.Program) compileProg prog = second kernelsToOpenCL <$> compileProgOpenCL prog

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-}  -- | High-level API for invoking the Futhark compiler.@@ -13,7 +12,6 @@     handleWarnings,     module Futhark.Compiler.Program,     readProgram,-    readLibrary,     readProgramOrDie,   ) where@@ -46,7 +44,9 @@     -- | If true, error on any warnings.     futharkWerror :: Bool,     -- | If True, ignore @unsafe@.-    futharkSafe :: Bool+    futharkSafe :: Bool,+    -- | Additional functions that should be exposed as entry points.+    futharkEntryPoints :: [Name]   }  -- | The default compiler configuration.@@ -56,7 +56,8 @@     { futharkVerbose = (NotVerbose, Nothing),       futharkWarn = True,       futharkWerror = False,-      futharkSafe = False+      futharkSafe = False,+      futharkEntryPoints = []     }  -- | Print a compiler error to stdout.  The 'FutharkConfig' controls@@ -123,7 +124,9 @@   when (pipelineVerbose pipeline_config) $     logMsg ("Reading and type-checking source program" :: String)   (prog_imports, namesrc) <--    handleWarnings config $ (\(a, b, c) -> (a, (b, c))) <$> readProgram file+    handleWarnings config $+      (\(a, b, c) -> (a, (b, c)))+        <$> readProgram (futharkEntryPoints config) file    putNameSource namesrc   when (pipelineVerbose pipeline_config) $@@ -151,22 +154,15 @@ -- | Read and type-check a Futhark program, including all imports. readProgram ::   (MonadError CompilerError m, MonadIO m) =>+  [I.Name] ->   FilePath ->   m (Warnings, Imports, VNameSource)-readProgram = readLibrary . pure---- | Read and type-check a collection of Futhark files, including all--- imports.-readLibrary ::-  (MonadError CompilerError m, MonadIO m) =>-  [FilePath] ->-  m (Warnings, Imports, VNameSource)-readLibrary = readLibraryWithBasis emptyBasis+readProgram extra_eps = readLibrary extra_eps . pure  -- | Not verbose, and terminates process on error. readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource) readProgramOrDie file = liftIO $ do-  res <- runFutharkM (readProgram file) NotVerbose+  res <- runFutharkM (readProgram mempty file) NotVerbose   case res of     Left err -> do       dumpError newFutharkConfig err

@@ -14,11 +14,10 @@ import Control.Monad import Data.Maybe import Futhark.Compiler-import Futhark.IR (Prog)+import Futhark.IR (Name, Prog, nameFromString) import Futhark.IR.SOACS (SOACS) import Futhark.Pipeline import Futhark.Util.Options-import System.Console.GetOpt import System.FilePath import System.IO @@ -117,6 +116,11 @@       (NoArg $ Right $ \config -> config {compilerMode = ToExecutable})       "Generate an executable instead of a library (set by default).",     Option+      []+      ["server"]+      (NoArg $ Right $ \config -> config {compilerMode = ToServer})+      "Generate a server executable instead of a library.",+    Option       "w"       []       (NoArg $ Right $ \config -> config {compilerWarn = False})@@ -130,7 +134,20 @@       []       ["safe"]       (NoArg $ Right $ \config -> config {compilerSafe = True})-      "Ignore 'unsafe' in code."+      "Ignore 'unsafe' in code.",+    Option+      []+      ["entry-points"]+      ( ReqArg+          ( \arg -> Right $ \config ->+              config+                { compilerEntryPoints =+                    nameFromString arg : compilerEntryPoints config+                }+          )+          "NAME"+      )+      "Treat this function as an additional entry point."   ]  wrapOption :: CompilerOption cfg -> CoreCompilerOption cfg@@ -156,11 +173,16 @@     compilerWerror :: Bool,     compilerSafe :: Bool,     compilerWarn :: Bool,-    compilerConfig :: cfg+    compilerConfig :: cfg,+    compilerEntryPoints :: [Name]   }  -- | Are we compiling a library or an executable?-data CompilerMode = ToLibrary | ToExecutable deriving (Eq, Ord, Show)+data CompilerMode+  = ToLibrary+  | ToExecutable+  | ToServer+  deriving (Eq, Ord, Show)  -- | The configuration of the compiler. newCompilerConfig :: cfg -> CompilerConfig cfg@@ -172,7 +194,8 @@       compilerWerror = False,       compilerSafe = False,       compilerWarn = True,-      compilerConfig = x+      compilerConfig = x,+      compilerEntryPoints = mempty     }  outputFilePath :: FilePath -> CompilerConfig cfg -> FilePath@@ -185,5 +208,6 @@     { futharkVerbose = compilerVerbose config,       futharkWerror = compilerWerror config,       futharkSafe = compilerSafe config,-      futharkWarn = compilerWarn config+      futharkWarn = compilerWarn config,+      futharkEntryPoints = compilerEntryPoints config     }

@@ -5,7 +5,7 @@ -- | Low-level compilation parts.  Look at "Futhark.Compiler" for a -- more high-level API. module Futhark.Compiler.Program-  ( readLibraryWithBasis,+  ( readLibrary,     readImports,     Imports,     FileModule (..),@@ -18,9 +18,8 @@ import Control.Exception import Control.Monad import Control.Monad.Except-import Control.Monad.Reader import Control.Monad.State-import Data.List (intercalate)+import Data.List (intercalate, isPrefixOf) import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T@@ -36,40 +35,56 @@ import qualified System.FilePath.Posix as Posix import System.IO.Error --- | A little monad for reading and type-checking a Futhark program.-type CompilerM m = ReaderT [FilePath] (StateT ReaderState m)+readFileSafely :: String -> IO (Maybe (Either String (String, T.Text)))+readFileSafely filepath =+  (Just . Right . (filepath,) <$> T.readFile filepath) `catch` couldNotRead+  where+    couldNotRead e+      | isDoesNotExistError e =+        return Nothing+      | otherwise =+        return $ Just $ Left $ show e -data ReaderState = ReaderState-  { alreadyImported :: Imports,-    nameSource :: VNameSource,-    warnings :: E.Warnings-  }+newtype ReaderState = ReaderState+  {alreadyRead :: [(ImportName, E.UncheckedProg)]} --- | Pre-typechecked imports, including a starting point for the name source.-data Basis = Basis-  { basisImports :: Imports,-    basisNameSource :: VNameSource,-    -- | Files that should be implicitly opened.-    basisRoots :: [String]-  }+-- | A little monad for parsing a Futhark program.+type ReaderM m = StateT ReaderState m --- | A basis that contains no imports, and has a properly initialised--- name source.-emptyBasis :: Basis-emptyBasis =-  Basis-    { basisImports = mempty,-      basisNameSource = src,-      basisRoots = mempty-    }+runReaderM ::+  (MonadError CompilerError m) =>+  ReaderM m a ->+  m [(ImportName, E.UncheckedProg)]+runReaderM m = reverse . alreadyRead <$> execStateT m (ReaderState mempty)++readImportFile ::+  (MonadError CompilerError m, MonadIO m) =>+  ImportName ->+  ReaderM m (T.Text, FilePath)+readImportFile include = do+  -- First we try to find a file of the given name in the search path,+  -- 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 prelude_str prelude) of+    (Just (Right (filepath, s)), _) -> return (s, filepath)+    (Just (Left e), _) -> externalErrorS e+    (Nothing, Just t) -> return (t, prelude_str)+    (Nothing, Nothing) -> externalErrorS not_found   where-    src = newNameSource $ E.maxIntrinsicTag + 1+    prelude_str = "/" Posix.</> includeToString include Posix.<.> "fut" +    not_found =+      "Error at " ++ E.locStr (E.srclocOf include)+        ++ ": could not find import '"+        ++ includeToString include+        ++ "'."+ readImport ::   (MonadError CompilerError m, MonadIO m) =>   [ImportName] ->   ImportName ->-  CompilerM m ()+  ReaderM m () readImport steps include   | include `elem` steps =     externalErrorS $@@ -78,7 +93,7 @@           " -> "           (map includeToString $ reverse $ include : steps)   | otherwise = do-    already_done <- gets $ isJust . lookup (includeToString include) . alreadyImported+    already_done <- gets $ isJust . lookup include . alreadyRead      unless already_done $       uncurry (handleFile steps include) =<< readImportFile include@@ -89,102 +104,98 @@   ImportName ->   T.Text ->   FilePath ->-  CompilerM m ()-handleFile steps include file_contents file_name = do+  ReaderM m ()+handleFile steps import_name file_contents file_name = do   prog <- case parseFuthark file_name file_contents of     Left err -> externalErrorS $ show err     Right prog -> return prog -  mapM_ (readImport steps' . uncurry (mkImportFrom include)) $+  let steps' = import_name : steps+  mapM_ (readImport steps' . uncurry (mkImportFrom import_name)) $     E.progImports prog -  -- It is important to not read these before the above calls to-  -- readImport.-  imports <- gets alreadyImported-  src <- gets nameSource-  roots <- ask+  modify $ \s ->+    s {alreadyRead = (import_name, prog) : alreadyRead s} -  case E.checkProg imports src include $ prependRoots roots prog of-    (prog_ws, Left err) -> do-      prev_ws <- gets warnings-      let ws = prev_ws <> prog_ws-      externalError $-        if anyWarnings ws-          then ppr (prev_ws <> ws) </> line <> ppr err-          else ppr err-    (ws, Right (m, src')) ->-      modify $ \s ->-        s-          { alreadyImported = (includeToString include, m) : imports,-            nameSource = src',-            warnings = warnings s <> ws-          }-  where-    steps' = include : steps+-- | Pre-typechecked imports, including a starting point for the name source.+data Basis = Basis+  { basisImports :: Imports,+    basisNameSource :: VNameSource,+    -- | Files that should be implicitly opened.+    basisRoots :: [String]+  } -readFileSafely :: String -> IO (Maybe (Either String (String, T.Text)))-readFileSafely filepath =-  (Just . Right . (filepath,) <$> T.readFile filepath) `catch` couldNotRead+-- | A basis that contains no imports, and has a properly initialised+-- name source.+emptyBasis :: Basis+emptyBasis =+  Basis+    { basisImports = mempty,+      basisNameSource = src,+      basisRoots = mempty+    }   where-    couldNotRead e-      | isDoesNotExistError e =-        return Nothing-      | otherwise =-        return $ Just $ Left $ show e+    src = newNameSource $ E.maxIntrinsicTag + 1 -readImportFile ::-  (MonadError CompilerError m, MonadIO m) =>-  ImportName ->-  m (T.Text, FilePath)-readImportFile include = do-  -- First we try to find a file of the given name in the search path,-  -- 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 prelude_str prelude) of-    (Just (Right (filepath, s)), _) -> return (s, filepath)-    (Just (Left e), _) -> externalErrorS e-    (Nothing, Just t) -> return (t, prelude_str)-    (Nothing, Nothing) -> externalErrorS not_found+typeCheckProgram ::+  MonadError CompilerError m =>+  Basis ->+  [(ImportName, E.UncheckedProg)] ->+  m (E.Warnings, Imports, VNameSource)+typeCheckProgram basis =+  foldM f (mempty, basisImports basis, basisNameSource basis)   where-    prelude_str = "/" Posix.</> includeToString include Posix.<.> "fut"+    roots = ["/prelude/prelude"] -    not_found =-      "Error at " ++ E.locStr (E.srclocOf include)-        ++ ": could not find import '"-        ++ includeToString include-        ++ "'."+    f (ws, imports, src) (import_name, prog) = do+      let prog'+            | "/prelude" `isPrefixOf` includeToFilePath import_name = prog+            | otherwise = prependRoots roots prog+      case E.checkProg imports src import_name prog' of+        (prog_ws, Left err) -> do+          let ws' = ws <> prog_ws+          externalError $+            if anyWarnings ws'+              then ppr ws' </> line <> ppr err+              else ppr err+        (prog_ws, Right (m, src')) ->+          pure+            ( ws <> prog_ws,+              imports ++ [(includeToString import_name, m)],+              src'+            ) --- | Read Futhark files from some basis, and printing log messages if--- the first parameter is True.-readLibraryWithBasis ::-  (MonadError CompilerError m, MonadIO m) =>-  Basis ->+setEntryPoints ::+  [E.Name] ->   [FilePath] ->-  m-    ( E.Warnings,-      Imports,-      VNameSource-    )-readLibraryWithBasis builtin fps = do-  (_, imps, src) <--    runCompilerM builtin $-      readImport [] $ mkInitialImport "/prelude/prelude"-  let basis = Basis imps src ["/prelude/prelude"]-  readLibrary' basis fps+  [(ImportName, E.UncheckedProg)] ->+  [(ImportName, E.UncheckedProg)]+setEntryPoints extra_eps fps = map onProg+  where+    onProg (name, prog)+      | includeToFilePath name `elem` fps =+        (name, prog {E.progDecs = map onDec (E.progDecs prog)})+      | otherwise =+        (name, prog) --- | Read and type-check a Futhark library (multiple files, relative--- to the same search path), including all imports.-readLibrary' ::+    onDec (E.ValDec vb)+      | E.valBindName vb `elem` extra_eps =+        E.ValDec vb {E.valBindEntryPoint = Just E.NoInfo}+    onDec dec = dec++-- | Read and type-check some Futhark files.+readLibrary ::   (MonadError CompilerError m, MonadIO m) =>-  Basis ->+  -- | Extra functions that should be marked as entry points; only+  -- applies to the immediate files, not any imports imported.+  [E.Name] ->+  -- | The files to read.   [FilePath] ->-  m-    ( E.Warnings,-      Imports,-      VNameSource-    )-readLibrary' basis fps = runCompilerM basis $ mapM onFile fps+  m (E.Warnings, Imports, VNameSource)+readLibrary extra_eps fps =+  typeCheckProgram emptyBasis . setEntryPoints extra_eps fps <=< runReaderM $ do+    readImport [] (mkInitialImport "/prelude/prelude")+    mapM_ onFile fps   where     onFile fp = do       r <- liftIO $ readFileSafely fp@@ -208,22 +219,9 @@       Imports,       VNameSource     )-readImports basis imps =-  runCompilerM basis $ mapM (readImport []) imps--runCompilerM ::-  Monad m =>-  Basis ->-  CompilerM m a ->-  m (E.Warnings, [(String, FileModule)], VNameSource)-runCompilerM (Basis imports src roots) m = do-  let s = ReaderState (reverse imports) src mempty-  s' <- execStateT (runReaderT m roots) s-  return-    ( warnings s',-      reverse $ alreadyImported s',-      nameSource s'-    )+readImports basis imps = do+  files <- runReaderM $ mapM (readImport []) imps+  typeCheckProgram basis files  prependRoots :: [FilePath] -> E.UncheckedProg -> E.UncheckedProg prependRoots roots (E.Prog doc ds) =

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-}  -- | = Constructing Futhark ASTs

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}  -- | Futhark error definitions. module Futhark.Error

@@ -1,5 +1,3 @@-{-# LANGUAGE Safe #-}- -- | A convenient re-export of basic AST modules.  Note that -- "Futhark.IR.Lore" is not exported, as this would -- cause name clashes.  You are advised to use a qualified import of

@@ -134,6 +134,7 @@ import Futhark.Transform.Substitute import qualified Futhark.TypeCheck as TC import Futhark.Util+import Futhark.Util.Pretty (indent, ppr, text, (</>)) import qualified Futhark.Util.Pretty as PP import GHC.Generics (Generic) import Language.SexpGrammar as Sexp@@ -661,7 +662,7 @@     M.Map (Ext VName) (TPrimExp Int64 (Ext VName))   ) getExtMaps ctx_lst_ids =-  ( M.map leafExp $ M.mapKeys Free $ M.fromListWith (flip const) ctx_lst_ids,+  ( M.map leafExp $ M.mapKeys Free $ M.fromListWith (const id) ctx_lst_ids,     M.fromList $       mapMaybe         ( traverse@@ -757,15 +758,14 @@           (x_mem, x_mem_type) <- fetchCtx x_ext           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,-                  "\nand context elements: ",-                  pretty ctx_res-                ]+              pretty $+                "Index function unification failed (ReturnsNewBlock)"+                  </> "Ixfun of body result:"+                  </> indent 2 (ppr y_ixfun)+                  </> "Ixfun of return type:"+                  </> indent 2 (ppr x_ixfun)+                  </> "Context elements: "+                  </> indent 2 (ppr ctx_res)           case x_mem_type of             MemMem y_space ->               unless (x_space == y_space) $@@ -801,12 +801,12 @@       bad s =         TC.bad $           TC.TypeError $-            PP.pretty $+            pretty $               "Return type"-                PP.</> PP.indent 2 (ppTuple' rettype)-                PP.</> "cannot match returns of results"-                PP.</> PP.indent 2 (ppTuple' ts)-                PP.</> PP.text s+                </> indent 2 (ppTuple' rettype)+                </> "cannot match returns of results"+                </> indent 2 (ppTuple' ts)+                </> text s    unless (length (S.unions $ map extsInMemInfo rettype) == length ctx_res) $     TC.bad $

@@ -564,7 +564,7 @@   IxFun num ->   ShapeChange num ->   Maybe (IxFun num)-reshapeCoercion (IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do+reshapeCoercion (IxFun (lmad@(LMAD off dims) :| lmads) oldbase cg) newshape = do   let perm = lmadPermutation lmad   (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape   let hd_len = length head_coercions@@ -580,7 +580,7 @@             dims'             (newDims newshape)       lmad' = LMAD off dims''-  return $ IxFun (lmad' :| lmads) (newDims newshape) cg+  return $ IxFun (lmad' :| lmads) oldbase cg  -- | Handle the case where a reshape operation can stay inside a single LMAD. --@@ -603,7 +603,7 @@   IxFun num ->   ShapeChange num ->   Maybe (IxFun num)-reshapeOneLMAD ixfun@(IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do+reshapeOneLMAD ixfun@(IxFun (lmad@(LMAD off dims) :| lmads) oldbase cg) newshape = do   let perm = lmadPermutation lmad   (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape   let hd_len = length head_coercions@@ -678,7 +678,7 @@           sortBy (compare `on` fst) $             zip sup_inds dims_sup ++ zip rpt_inds repeats'       lmad' = LMAD off' dims'-  return $ IxFun (setLMADPermutation perm' lmad' :| lmads) (newDims newshape) cg+  return $ IxFun (setLMADPermutation perm' lmad' :| lmads) oldbase cg   where     consecutive _ [] = True     consecutive i [p] = i == p

@@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-}  -- | Definitions of primitive types, the values that inhabit these

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-}  -- | This module provides various simple ways to query and manipulate

@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-}  -- | Facilities for determining which names are used in some syntactic

@@ -417,7 +417,7 @@     ext (Free _) = Nothing  -- | If all dimensions of the given 'ExtShape' are statically known,--- change to the corresponding 'Shape'.+-- change to the corresponding t'Shape'. hasStaticShape :: TypeBase ExtShape u -> Maybe (TypeBase Shape u) hasStaticShape (Prim bt) = Just $ Prim bt hasStaticShape (Mem space) = Just $ Mem space

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-}  -- | A simple representation with SOACs and nested parallelism.

@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Futhark.IR.SOACS.Simplify

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-}  -- | The most primitive ("core") aspects of the AST.  Split out of

@@ -1,5 +1,3 @@-{-# LANGUAGE Safe #-}- -- | -- -- Functions for generic traversals across Futhark syntax trees.  The

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}@@ -28,6 +27,7 @@ import Futhark.Internalise.TypesValues import Futhark.Transform.Rename as I import Futhark.Util (splitAt3)+import Futhark.Util.Pretty (prettyOneLine) import Language.Futhark as E hiding (TypeArg) import Language.Futhark.Semantic (Imports) @@ -177,7 +177,7 @@       | otherwise =         [I.TypeOpaque desc $ length ts]       where-        desc = maybe (pretty t') typeExpOpaqueName $ E.entryAscribed t+        desc = maybe (prettyOneLine t') typeExpOpaqueName $ E.entryAscribed t         t' = noSizes (E.entryType t) `E.setUniqueness` Nonunique     typeExpOpaqueName (TEApply te TypeArgExpDim {} _) =       typeExpOpaqueName te@@ -187,7 +187,7 @@             ++ "_"             ++ show (1 + d)             ++ "d"-    typeExpOpaqueName te = pretty te+    typeExpOpaqueName te = prettyOneLine te      withoutDims (TEArray te _ _) =       let (d, te') = withoutDims te@@ -493,7 +493,8 @@       ()         | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->           internalise desc-        | Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do+        | baseTag (qualLeaf qfname) <= maxIntrinsicTag,+          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'@@ -860,6 +861,11 @@       return ([], id_ses, rest_ses)     compares (E.PatternParens pat _) ses =       compares pat ses+    -- XXX: treat empty tuples and records as bool.+    compares (E.TuplePattern [] loc) ses =+      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses+    compares (E.RecordPattern [] loc) ses =+      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses     compares (E.TuplePattern pats _) ses =       comparesMany pats ses     compares (E.RecordPattern fs _) ses =

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}  -- | Internalising bindings. module Futhark.Internalise.Bindings

@@ -168,6 +168,8 @@   addValBind $ vb {valBindBody = e}  {-# NOINLINE transformProg #-}++-- | Perform the transformation. transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] transformProg vbinds =   modifyNameSource $ \namesrc ->

@@ -13,7 +13,7 @@ import Control.Monad.Writer import Data.Either import Data.List (find, unzip4)-import Data.Maybe (mapMaybe)+import Data.Maybe (isNothing, mapMaybe) import Futhark.Analysis.PrimExp.Convert import Futhark.Construct import Futhark.IR.Aliases@@ -126,6 +126,14 @@       | Just (DesiredUpdate bindee_nm bindee_dec _cs src slice _val) <-           find ((== v) . updateValue) updates = do         Returns _ se <- Just ret++        -- The slice we're writing per thread must fully cover the+        -- underlying dimensions.+        guard $+          let (dims', slice') =+                unzip . drop (length gtids) . filter (isNothing . dimFix . snd) $+                  zip (arrayDims (typeOf bindee_dec)) slice+           in isFullSlice (Shape dims') slice'          Just $ do           (slice', bodystms) <-

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}  -- | This module implements facilities for determining whether a -- reduction or fold can be expressed in a closed form (i.e. not as a

@@ -574,6 +574,7 @@ cheapExp (BasicOp CmpOp {}) = True cheapExp (BasicOp ConvOp {}) = True cheapExp (BasicOp Copy {}) = False+cheapExp (BasicOp Replicate {}) = False cheapExp (BasicOp Manifest {}) = False cheapExp DoLoop {} = False cheapExp (If _ tbranch fbranch _) =

@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -806,6 +805,10 @@     Just (Copy src, cs)       | Just dims <- arrayDims <$> seType (Var src),         length inds == length dims,+        -- It is generally not safe to simplify a slice of a copy,+        -- because the result may be used in an in-place update of the+        -- original.+        Just _ <- mapM dimFix inds,         not consuming,         ST.available src vtable ->         Just $ pure $ IndexResult cs src inds

@@ -237,15 +237,17 @@ -- -- The third category duplicates computation, so we only want to do it -- when absolutely necessary.  Currently, this is necessary for--- results that are views of an array (slicing, rotate, etc), because--- these cannot be efficiently represented by a scalar segmap (they'll--- be manifested in memory).+-- results that are views of an array (slicing, rotate, etc) and which+-- results are used after the prelude, because these cannot be+-- efficiently represented by a scalar segmap (they'll be manifested+-- in memory). partitionPrelude ::   VarianceTable ->   Stms Kernels ->   Names ->+  Names ->   (Stms Kernels, Stms Kernels, Stms Kernels)-partitionPrelude variance prestms private =+partitionPrelude variance prestms private used_after =   (invariant_prestms, precomputed_variant_prestms, recomputed_variant_prestms)   where     invariantTo names stm =@@ -264,7 +266,9 @@     mustBeInlinedExp (BasicOp Rearrange {}) = True     mustBeInlinedExp (BasicOp Reshape {}) = True     mustBeInlinedExp _ = False-    mustBeInlined = mustBeInlinedExp . stmExp+    mustBeInlined stm =+      mustBeInlinedExp (stmExp stm)+        && any (`nameIn` used_after) (patternNames (stmPattern stm))      must_be_inlined =       namesFromList $@@ -302,7 +306,7 @@             precomputed_variant_prestms,             recomputed_variant_prestms             ) =-              partitionPrelude variance prestms private'+              partitionPrelude variance prestms private' used        addStms invariant_prestms @@ -337,11 +341,15 @@   Result ->   TileM (Stms Kernels, Tiling, TiledBody) tileDoLoop initial_space variance prestms used_in_body (host_stms, tiling, tiledBody) res_ts pat aux merge i it bound poststms poststms_res = do-  let ( invariant_prestms,+  let prestms_used =+        used_in_body+          <> freeIn poststms+          <> freeIn poststms_res+      ( invariant_prestms,         precomputed_variant_prestms,         recomputed_variant_prestms         ) =-          partitionPrelude variance prestms tiled_kdims+          partitionPrelude variance prestms tiled_kdims prestms_used    let (mergeparams, mergeinits) = unzip merge @@ -356,10 +364,7 @@         let live_set =               namesToList $                 liveSet precomputed_variant_prestms $-                  freeIn recomputed_variant_prestms-                    <> used_in_body-                    <> freeIn poststms-                    <> freeIn poststms_res+                  freeIn recomputed_variant_prestms <> prestms_used          prelude_arrs <-           inScopeOf precomputed_variant_prestms $

@@ -166,7 +166,9 @@    case find badVariant $ M.elems variant_allocs of     Just v ->-      throwError $ "Cannot handle un-sliceable allocation size: " ++ pretty v+      throwError $+        "Cannot handle un-sliceable allocation size: " ++ pretty v+          ++ "\nLikely cause: irregular nested operations inside parallel constructs."     Nothing ->       return () 

@@ -379,12 +379,20 @@     distributeIfPossible acc >>= \case       Nothing -> addStmToAcc stm acc       Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc'-maybeDistributeStm bnd@(Let pat _ (DoLoop [] val form@ForLoop {} body)) acc+maybeDistributeStm bnd@(Let pat aux (DoLoop [] val form@ForLoop {} body)) acc   | null (patternContextElements pat),     bodyContainsParallelism body =     distributeSingleStm acc bnd >>= \case       Just (kernels, res, nest, acc')-        | not $ freeIn form `namesIntersect` boundInKernelNest nest,+        | -- XXX: We cannot distribute if this loop depends on+          -- certificates bound within the loop nest (well, we could,+          -- but interchange would not be valid).  This is not a+          -- fundamental restriction, but an artifact of our+          -- certificate representation, which we should probably+          -- rethink.+          not $+            (freeIn form <> freeIn aux)+              `namesIntersect` boundInKernelNest nest,           Just (perm, pat_unused) <- permutationAndMissing pat res ->           -- We need to pretend pat_unused was used anyway, by adding           -- it to the kernel nest.

@@ -0,0 +1,305 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | FutharkScript is a (tiny) subset of Futhark used to write small+-- expressions that are evaluated by server executables.  The @futhark+-- literate@ command is the main user.+module Futhark.Script+  ( -- * Server+    ScriptServer,+    withScriptServer,++    -- * Expressions, values, and types+    Exp (..),+    parseExp,+    varsInExp,+    ScriptValueType (..),+    ScriptValue (..),+    scriptValueType,+    ExpValue,++    -- * Evaluation+    evalExp,+    getExpValue,+    evalExpToGround,+    valueToExp,+    freeValue,+  )+where++import Control.Monad.Except+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Char+import Data.Foldable (toList)+import Data.IORef+import Data.List (intersperse)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Traversable+import Data.Void+import Futhark.Server+import qualified Futhark.Test.Values as V+import qualified Futhark.Test.Values.Parser as V+import Futhark.Util (nubOrd)+import Futhark.Util.Pretty hiding (float, line, sep, string, (</>), (<|>))+import Language.Futhark.Prop (primValueType)+import Language.Futhark.Syntax (PrimValue (..))+import System.IO+import System.IO.Temp+import Text.Megaparsec++-- | Like a 'Server', but keeps a bit more state to make FutharkScript+-- more convenient.+data ScriptServer = ScriptServer Server (IORef Int)++-- | Start a server, execute an action, then shut down the server.+-- Similar to 'withServer'.+withScriptServer :: FilePath -> [FilePath] -> (ScriptServer -> IO a) -> IO a+withScriptServer prog options f = withServer prog options $ \server -> do+  counter <- newIORef 0+  f $ ScriptServer server counter++-- | A FutharkScript expression.  This is a simple AST that might not+-- correspond exactly to what the user wrote (e.g. no parentheses or+-- source locations).  This is fine for small expressions, which is+-- all this is meant for.+data Exp+  = Call EntryName [Exp]+  | Const PrimValue+  | Tuple [Exp]+  | Record [(T.Text, Exp)]+  | -- | Server-side variable, *not* Futhark variable (these are+    -- handled in 'Call').+    ServerVar TypeName VarName+  deriving (Show)++instance Pretty Exp where+  ppr = pprPrec 0+  pprPrec _ (ServerVar _ v) = "$" <> strictText v+  pprPrec _ (Const v) = ppr v+  pprPrec i (Call v args) =+    parensIf (i > 0) $ strictText v <+> spread (map (pprPrec 1) args)+  pprPrec _ (Tuple vs) =+    parens $ commasep $ map ppr vs+  pprPrec _ (Record m) = braces $ commasep $ map field m+    where+      field (k, v) = ppr k <> equals <> ppr v++type Parser = Parsec Void T.Text++parseEntryName :: Parser EntryName+parseEntryName =+  fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent)+  where+    constituent c = isAlphaNum c || c == '_'++lexeme :: Parser () -> Parser a -> Parser a+lexeme sep p = p <* sep++inParens :: Parser () -> Parser a -> Parser a+inParens sep = between (lexeme sep "(") (lexeme sep ")")++inBraces :: Parser () -> Parser a -> Parser a+inBraces sep = between (lexeme sep "{") (lexeme sep "}")++-- | Parse a FutharkScript expression.+parseExp :: Parser () -> Parser Exp+parseExp sep =+  choice+    [ inParens sep (mkTuple <$> (parseExp sep `sepBy` pComma)),+      inBraces sep (Record <$> (pField `sepBy` pComma)),+      Call <$> lexeme sep parseEntryName <*> many (parseExp sep),+      Const <$> lexeme sep V.parsePrimValue+    ]+  where+    pField = (,) <$> parseEntryName <*> (pEquals *> parseExp sep)+    pEquals = lexeme sep "="+    pComma = lexeme sep ","+    mkTuple [v] = v+    mkTuple vs = Tuple vs++prettyFailure :: CmdFailure -> T.Text+prettyFailure (CmdFailure bef aft) =+  T.unlines $ bef ++ aft++cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()+cmdMaybe m = maybe (pure ()) (throwError . prettyFailure) =<< liftIO m++cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a+cmdEither m = either (throwError . prettyFailure) pure =<< liftIO m++readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value+readVar server v =+  either throwError pure <=< liftIO $+    withSystemTempFile "futhark-server-read" $ \tmpf tmpf_h -> do+      hClose tmpf_h+      store_res <- cmdStore server tmpf [v]+      case store_res of+        Just err -> pure $ Left $ prettyFailure err+        Nothing -> do+          s <- LBS.readFile tmpf+          case V.readValues s of+            Just [val] -> pure $ Right val+            _ -> pure $ Left "Invalid data file produced by Futhark server."++writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> PrimValue -> m ()+writeVar server v val =+  cmdMaybe . liftIO . withSystemTempFile "futhark-server-write" $ \tmpf tmpf_h -> do+    T.hPutStr tmpf_h $ prettyText val+    hClose tmpf_h+    let t = prettyText $ primValueType val+    cmdRestore server tmpf [(v, t)]++-- | A ScriptValue is either a base value or a partially applied+-- function.  We don't have real first-class functions in+-- FutharkScript, but we sort of have closures.+data ScriptValue v+  = SValue TypeName v+  | -- | Ins, then outs.+    SFun EntryName [TypeName] [TypeName] [ScriptValue v]++instance Functor ScriptValue where+  fmap = fmapDefault++instance Foldable ScriptValue where+  foldMap = foldMapDefault++instance Traversable ScriptValue where+  traverse f (SValue t v) = SValue t <$> f v+  traverse f (SFun fname ins outs vs) =+    SFun fname ins outs <$> traverse (traverse f) vs++-- | The type of a 'ScriptValue' - either a value type or a function type.+data ScriptValueType+  = STValue TypeName+  | -- | Ins, then outs.+    STFun [TypeName] [TypeName]+  deriving (Show)++instance Pretty ScriptValueType where+  ppr (STValue t) = ppr t+  ppr (STFun ins outs) =+    spread $ intersperse "->" (map ppr ins ++ [outs'])+    where+      outs' = case outs of+        [out] -> strictText out+        _ -> parens $ commasep $ map strictText outs++-- | The value that is produced by expression evaluation.  This+-- representation keeps all values on the server.+type ExpValue = V.Compound (ScriptValue VarName)++-- | The type of a 'ScriptValue'.+scriptValueType :: ScriptValue v -> ScriptValueType+scriptValueType (SValue t _) = STValue t+scriptValueType (SFun _ ins outs _) = STFun ins outs++serverVarsInValue :: ExpValue -> S.Set VarName+serverVarsInValue = S.fromList . concatMap isVar . toList+  where+    isVar (SValue _ x) = [x]+    isVar (SFun _ _ _ closure) = concatMap isVar $ toList closure++-- | Convert a value into a corresponding expression.+valueToExp :: ExpValue -> Exp+valueToExp (V.ValueAtom (SValue t v)) =+  ServerVar t v+valueToExp (V.ValueAtom (SFun fname _ _ closure)) =+  Call fname $ map (valueToExp . V.ValueAtom) closure+valueToExp (V.ValueRecord fs) =+  Record $ M.toList $ M.map valueToExp fs+valueToExp (V.ValueTuple fs) =+  Tuple $ map valueToExp fs++-- | Evaluate a FutharkScript expression relative to some running server.+evalExp :: (MonadError T.Text m, MonadIO m) => ScriptServer -> Exp -> m ExpValue+evalExp (ScriptServer server counter) top_level_e = do+  vars <- liftIO $ newIORef []+  let newVar base = liftIO $ do+        x <- readIORef counter+        modifyIORef counter (+ 1)+        let v = base <> prettyText x+        modifyIORef vars (v :)+        pure v++      evalExpToVar e = do+        vs <- evalExpToVars e+        case vs of+          V.ValueAtom (SValue _ v) -> pure v+          V.ValueAtom SFun {} ->+            throwError $ "Expression " <> prettyText e <> " not fully applied."+          _ ->+            throwError $ "Expression " <> prettyText e <> " produced more than one value."+      evalExpToVars (ServerVar t v) =+        pure $ V.ValueAtom $ SValue t v+      evalExpToVars (Call name es) = do+        ins <- mapM evalExpToVar es+        in_types <- cmdEither $ cmdInputs server name+        out_types <- cmdEither $ cmdOutputs server name+        if length in_types == length ins+          then do+            outs <- replicateM (length out_types) $ newVar "out"+            void $ cmdEither $ cmdCall server name outs ins+            pure $ V.mkCompound $ zipWith SValue out_types outs+          else+            pure . V.ValueAtom . SFun name in_types out_types $+              zipWith SValue in_types ins+      evalExpToVars (Const val) = do+        v <- newVar "const"+        writeVar server v val+        pure $ V.ValueAtom $ SValue (prettyText (primValueType val)) v+      evalExpToVars (Tuple es) =+        V.ValueTuple <$> mapM evalExpToVars es+      evalExpToVars e@(Record m) = do+        when (length (nubOrd (map fst m)) /= length (map fst m)) $+          throwError $ "Record " <> prettyText e <> " has duplicate fields."+        V.ValueRecord <$> traverse evalExpToVars (M.fromList m)++  let freeNonresultVars v = do+        let v_vars = serverVarsInValue v+        to_free <- liftIO $ filter (`S.notMember` v_vars) <$> readIORef vars+        cmdMaybe $ cmdFree server to_free+        pure v+      freeVarsOnError e = do+        -- We are intentionally ignoring any errors produced by+        -- cmdFree, because we already have another error to+        -- propagate.  Also, not all of the variables that we put in+        -- 'vars' might actually exist server-side, if we failed in a+        -- Call.+        void $ liftIO $ cmdFree server =<< readIORef vars+        throwError e+  (freeNonresultVars =<< evalExpToVars top_level_e) `catchError` freeVarsOnError++-- | Read actual values from the server.  Fails for values that have+-- no well-defined external representation.+getExpValue ::+  (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m (V.Compound V.Value)+getExpValue (ScriptServer server _) e =+  traverse toGround =<< traverse (traverse (readVar server)) e+  where+    toGround (SFun fname _ _ _) =+      throwError $ "Function " <> fname <> " not fully applied."+    toGround (SValue _ v) = pure v++-- | Like 'evalExp', but requires all values to be non-functional.+evalExpToGround ::+  (MonadError T.Text m, MonadIO m) => ScriptServer -> Exp -> m (V.Compound V.Value)+evalExpToGround server e = getExpValue server =<< evalExp server e++-- | The set of Futhark variables that are referenced by the+-- expression - these will have to be entry points in the Futhark+-- program.+varsInExp :: Exp -> S.Set EntryName+varsInExp ServerVar {} = mempty+varsInExp (Call v es) = S.insert v $ foldMap varsInExp es+varsInExp (Tuple es) = foldMap varsInExp es+varsInExp (Record fs) = foldMap (foldMap varsInExp) fs+varsInExp Const {} = mempty++-- | Release all the server-side variables in the value.  Yes,+-- FutharkScript has manual memory management...+freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m ()+freeValue (ScriptServer server _) =+  cmdMaybe . cmdFree server . S.toList . serverVarsInValue

@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Haskell code for interacting with a Futhark server program (a+-- program compiled with @--server@).+module Futhark.Server+  ( Server,+    withServer,+    CmdFailure (..),+    VarName,+    TypeName,+    EntryName,+    cmdRestore,+    cmdStore,+    cmdCall,+    cmdFree,+    cmdInputs,+    cmdOutputs,+    cmdClear,+    cmdReport,+  )+where++import Control.Exception+import Control.Monad+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Futhark.Util (isEnvVarAtLeast)+import System.Directory (removeFile)+import System.Exit+import System.IO hiding (stdin, stdout)+import System.IO.Temp+import qualified System.Process as P++-- | A handle to a running server.+data Server = Server+  { serverStdin :: Handle,+    serverStdout :: Handle,+    serverErrLog :: FilePath,+    serverProc :: P.ProcessHandle,+    serverDebug :: Bool+  }++startServer :: FilePath -> [FilePath] -> IO Server+startServer prog options = do+  tmpdir <- getCanonicalTemporaryDirectory+  (err_log_f, err_log_h) <- openTempFile tmpdir "futhark-server-stderr.log"+  (Just stdin, Just stdout, Nothing, phandle) <-+    P.createProcess+      ( (P.proc prog options)+          { P.std_err = P.UseHandle err_log_h,+            P.std_in = P.CreatePipe,+            P.std_out = P.CreatePipe+          }+      )++  code <- P.getProcessExitCode phandle+  case code of+    Just (ExitFailure e) ->+      error $ "Cannot start " ++ prog ++ ": error " ++ show e+    _ ->+      pure $+        Server+          { serverStdin = stdin,+            serverStdout = stdout,+            serverProc = phandle,+            serverDebug = isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 1,+            serverErrLog = err_log_f+          }++stopServer :: Server -> IO ()+stopServer s = do+  hClose $ serverStdin s+  void $ P.waitForProcess $ serverProc s+  removeFile $ serverErrLog s++-- | Start a server, execute an action, then shut down the server.+withServer :: FilePath -> [FilePath] -> (Server -> IO a) -> IO a+withServer prog options = bracket (startServer prog options) stopServer++-- Read lines of response until the next %%% OK (which is what+-- indicates that the server is ready for new instructions).+responseLines :: Server -> IO [Text]+responseLines s = do+  l <- T.hGetLine $ serverStdout s+  when (serverDebug s) $+    T.hPutStrLn stderr $ "<<< " <> l+  case l of+    "%%% OK" -> pure []+    _ -> (l :) <$> responseLines s++-- | The command failed, and this is why.  The first 'Text' is any+-- output before the failure indincator, and the second Text is the+-- output after the indicator.+data CmdFailure = CmdFailure {failureLog :: [Text], failureMsg :: [Text]}+  deriving (Eq, Ord, Show)++-- Figure out whether the response is a failure, and if so, return the+-- failure message.+checkForFailure :: [Text] -> Either CmdFailure [Text]+checkForFailure [] = Right []+checkForFailure ("%%% FAILURE" : ls) = Left $ CmdFailure mempty ls+checkForFailure (l : ls) =+  case checkForFailure ls of+    Left (CmdFailure xs ys) -> Left $ CmdFailure (l : xs) ys+    Right ls' -> Right $ l : ls'++sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])+sendCommand s command = do+  let command' = T.unwords command++  when (serverDebug s) $+    T.hPutStrLn stderr $ ">>> " <> command'++  T.hPutStrLn (serverStdin s) command'+  hFlush $ serverStdin s+  checkForFailure <$> responseLines s `catch` onError+  where+    onError :: IOError -> IO a+    onError e = do+      code <- P.getProcessExitCode $ serverProc s+      let code_msg =+            case code of+              Just (ExitFailure x) ->+                "\nServer process exited unexpectedly with exit code: " ++ show x+              _ -> mempty+      stderr_s <- readFile $ serverErrLog s+      error $+        "After sending command " ++ show command ++ " to server process:"+          ++ show e+          ++ code_msg+          ++ "\nServer stderr:\n"+          ++ stderr_s++-- | The name of a server-side variable.+type VarName = Text++-- | The name of a server-side type.+type TypeName = Text++-- | The name of an entry point.+type EntryName = Text++helpCmd :: Server -> [Text] -> IO (Maybe CmdFailure)+helpCmd s cmd =+  either Just (const Nothing) <$> sendCommand s cmd++cmdRestore :: Server -> FilePath -> [(VarName, TypeName)] -> IO (Maybe CmdFailure)+cmdRestore s fname vars = helpCmd s $ "restore" : T.pack fname : concatMap f vars+  where+    f (v, t) = [v, t]++cmdStore :: Server -> FilePath -> [VarName] -> IO (Maybe CmdFailure)+cmdStore s fname vars = helpCmd s $ "store" : T.pack fname : vars++cmdCall :: Server -> EntryName -> [VarName] -> [VarName] -> IO (Either CmdFailure [T.Text])+cmdCall s entry outs ins =+  sendCommand s $ "call" : entry : outs ++ ins++cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure)+cmdFree s vs = helpCmd s $ "free" : vs++cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])+cmdInputs s entry =+  sendCommand s ["inputs", entry]++cmdOutputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])+cmdOutputs s entry =+  sendCommand s ["outputs", entry]++cmdClear :: Server -> IO (Maybe CmdFailure)+cmdClear s = helpCmd s ["clear"]++cmdReport :: Server -> IO (Either CmdFailure [T.Text])+cmdReport s = sendCommand s ["report"]

@@ -14,12 +14,15 @@     FutharkExe (..),     getValues,     getValuesBS,+    withValuesFile,     compareValues,     compareValues1,+    checkResult,     testRunReferenceOutput,     getExpectedResult,     compileProgram,     runProgram,+    readResults,     ensureReferenceOutput,     determineTuning,     binaryName,@@ -46,6 +49,7 @@ import qualified Control.Exception.Base as E import Control.Monad import Control.Monad.Except+import qualified Data.Binary as Bin import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as BS import Data.Char@@ -57,16 +61,11 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Void-import Futhark.Analysis.Metrics-import Futhark.IR.Primitive-  ( FloatType (..),-    IntType (..),-    floatByteSize,-    floatValue,-    intByteSize,-    intValue,-  )+import Futhark.Analysis.Metrics.Type+import Futhark.IR.Primitive (floatByteSize, intByteSize)+import Futhark.Server import Futhark.Test.Values+import Futhark.Test.Values.Parser import Futhark.Util (directoryContents, pmapIO) import Futhark.Util.Pretty (pretty, prettyText) import Language.Futhark.Prop (primByteSize, primValueType)@@ -159,7 +158,7 @@ data GenValue   = -- | Generate a value of the given rank and primitive     -- type.  Scalars are considered 0-ary arrays.-    GenValue [Int] PrimType+    GenValue ValueType   | -- | A fixed non-randomised primitive value.     GenPrim PrimValue   deriving (Show)@@ -167,7 +166,7 @@ -- | A prettyprinted representation of type of value produced by a -- 'GenValue'. genValueType :: GenValue -> String-genValueType (GenValue ds t) =+genValueType (GenValue (ValueType ds t)) =   concatMap (\d -> "[" ++ show d ++ "]") ds ++ pretty t genValueType (GenPrim v) =   pretty v@@ -192,12 +191,15 @@  type Parser = Parsec Void T.Text +postlexeme :: Parser ()+postlexeme = void $ hspace *> optional (try $ eol *> "--" *> postlexeme)+ lexeme :: Parser a -> Parser a-lexeme p = p <* space+lexeme p = p <* postlexeme  -- Like 'lexeme', but does not consume trailing linebreaks. lexeme' :: Parser a -> Parser a-lexeme' p = p <* many (oneOf (" \t" :: String))+lexeme' p = p <* hspace  lexstr :: T.Text -> Parser () lexstr = void . try . lexeme . string@@ -218,22 +220,24 @@   where     num c = ord c - ord '0' -parseDescription :: Parser T.Text-parseDescription = lexeme $ T.pack <$> (anySingle `manyTill` parseDescriptionSeparator)+restOfLine :: Parser T.Text+restOfLine = do+  l <- restOfLine_+  if T.null l then void eol else void eol <|> eof+  pure l -parseDescriptionSeparator :: Parser ()-parseDescriptionSeparator =-  try-    ( string descriptionSeparator-        >> void (satisfy isSpace `manyTill` newline)-    )-    <|> eof+restOfLine_ :: Parser T.Text+restOfLine_ = takeWhileP Nothing (/= '\n') -descriptionSeparator :: T.Text-descriptionSeparator = "=="+parseDescription :: Parser T.Text+parseDescription =+  T.unlines <$> pDescLine `manyTill` pDescriptionSeparator+  where+    pDescLine = "--" *> restOfLine+    pDescriptionSeparator = void $ "-- ==" *> postlexeme  parseTags :: Parser [T.Text]-parseTags = lexstr "tags" *> braces (many parseTag) <|> pure []+parseTags = lexeme' "tags" *> braces (many parseTag) <|> pure []   where     parseTag = T.pack <$> lexeme (some $ satisfy tagConstituent) @@ -252,22 +256,24 @@ parseInputOutputs = do   entrys <- parseEntryPoints   cases <- parseRunCases-  return $ map (`InputOutputs` cases) entrys+  return $+    if null cases+      then []+      else map (`InputOutputs` cases) entrys  parseEntryPoints :: Parser [T.Text]-parseEntryPoints = (lexstr "entry:" *> many entry <* space) <|> pure ["main"]+parseEntryPoints =+  (lexeme' "entry:" *> many entry <* postlexeme)+    <|> pure ["main"]   where     constituent c = not (isSpace c) && c /= '}'     entry = lexeme' $ T.pack <$> some (satisfy constituent)  parseRunTags :: Parser [String]-parseRunTags = many parseTag-  where-    parseTag = try $-      lexeme $ do-        s <- some $ satisfy tagConstituent-        guard $ s `notElem` ["input", "structure", "warning"]-        return s+parseRunTags = many . try . lexeme' $ do+  s <- some $ satisfy tagConstituent+  guard $ s `notElem` ["input", "structure", "warning"]+  return s  parseRunCases :: Parser [TestRun] parseRunCases = parseRunCases' (0 :: Int)@@ -313,7 +319,7 @@  parseExpectedError :: Parser ExpectedError parseExpectedError = lexeme $ do-  s <- T.strip <$> restOfLine+  s <- T.strip <$> restOfLine_ <* postlexeme   if T.null s     then return AnyError     else -- blankCompOpt creates a regular expression that treats@@ -326,110 +332,24 @@ parseGenValue :: Parser GenValue parseGenValue =   choice-    [ GenValue <$> many dim <*> parsePrimType,-      lexeme $-        GenPrim-          <$> choice-            [ i8,-              i16,-              i32,-              i64,-              u8,-              u16,-              u32,-              u64,-              f32,-              f64,-              int SignedValue Int32 ""-            ]-    ]-  where-    digits = some (satisfy isDigit)-    dim =-      between (lexstr "[") (lexstr "]") $-        lexeme $ read <$> digits--    readint :: String -> Integer-    readint = read -- To avoid warnings.-    readfloat :: String -> Double-    readfloat = read -- To avoid warnings.-    int f t s =-      try $-        lexeme $-          f . intValue t . readint <$> digits-            <* string s-            <* notFollowedBy (satisfy isAlphaNum)-    i8 = int SignedValue Int8 "i8"-    i16 = int SignedValue Int16 "i16"-    i32 = int SignedValue Int32 "i32"-    i64 = int SignedValue Int64 "i64"-    u8 = int UnsignedValue Int8 "u8"-    u16 = int UnsignedValue Int16 "u16"-    u32 = int UnsignedValue Int32 "u32"-    u64 = int UnsignedValue Int64 "u64"--    optSuffix s suff = do-      s' <- s-      ((s' <>) <$> suff) <|> pure s'--    float f t s =-      try $-        lexeme $-          f . floatValue t . readfloat-            <$> (digits `optSuffix` (char '.' *> (("." <>) <$> digits)))-            <* string s-            <* notFollowedBy (satisfy isAlphaNum)-    f32 = float FloatValue Float32 "f32"-    f64 = float FloatValue Float64 "f64"--parsePrimType :: Parser PrimType-parsePrimType =-  choice-    [ lexstr "i8" $> Signed Int8,-      lexstr "i16" $> Signed Int16,-      lexstr "i32" $> Signed Int32,-      lexstr "i64" $> Signed Int64,-      lexstr "u8" $> Unsigned Int8,-      lexstr "u16" $> Unsigned Int16,-      lexstr "u32" $> Unsigned Int32,-      lexstr "u64" $> Unsigned Int64,-      lexstr "f32" $> FloatType Float32,-      lexstr "f64" $> FloatType Float64,-      lexstr "bool" $> Bool+    [ GenValue <$> lexeme parseType,+      GenPrim <$> lexeme parsePrimValue     ]  parseValues :: Parser Values parseValues =-  do-    s <- parseBlock-    case valuesFromByteString "input block contents" $ BS.fromStrict $ T.encodeUtf8 s of-      Left err -> fail err-      Right vs -> return $ Values vs-    <|> lexstr "@" *> lexeme (InFile . T.unpack <$> nextWord)--parseBlock :: Parser T.Text-parseBlock = lexeme $ braces (T.pack <$> parseBlockBody 0)--parseBlockBody :: Int -> Parser String-parseBlockBody n = do-  c <- lookAhead anySingle-  case (c, n) of-    ('}', 0) -> return mempty-    ('}', _) -> (:) <$> anySingle <*> parseBlockBody (n -1)-    ('{', _) -> (:) <$> anySingle <*> parseBlockBody (n + 1)-    _ -> (:) <$> anySingle <*> parseBlockBody n--restOfLine :: Parser T.Text-restOfLine = T.pack <$> (anySingle `manyTill` (void newline <|> eof))--nextWord :: Parser T.Text-nextWord = T.pack <$> (anySingle `manyTill` satisfy isSpace)+  choice+    [ Values <$> braces (many $ parseValue postlexeme),+      InFile . T.unpack <$> (lexstr "@" *> lexeme nextWord)+    ]+  where+    nextWord = takeWhileP Nothing $ not . isSpace  parseWarning :: Parser WarningTest parseWarning = lexstr "warning:" >> parseExpectedWarning   where     parseExpectedWarning = lexeme $ do-      s <- T.strip <$> restOfLine+      s <- T.strip <$> restOfLine_       ExpectedWarning s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)  parseExpectedStructure :: Parser StructureTest@@ -458,68 +378,41 @@ testSpec =   ProgramTest <$> parseDescription <*> parseTags <*> parseAction -parserState :: Int -> FilePath -> s -> State s e-parserState line name t =-  State-    { stateInput = t,-      stateOffset = 0,-      statePosState =-        PosState-          { pstateInput = t,-            pstateOffset = 0,-            pstateSourcePos =-              SourcePos-                { sourceName = name,-                  sourceLine = mkPos line,-                  sourceColumn = mkPos 3-                },-            pstateTabWidth = defaultTabWidth,-            pstateLinePrefix = "-- "-          },-      stateParseErrors = []-    }--readTestSpec :: Int -> String -> T.Text -> Either (ParseErrorBundle T.Text Void) ProgramTest-readTestSpec line name t =-  snd $ runParser' (testSpec <* eof) $ parserState line name t--readInputOutputs :: Int -> String -> T.Text -> Either (ParseErrorBundle T.Text Void) [InputOutputs]-readInputOutputs line name t =-  snd $-    runParser' (parseDescription *> space *> parseInputOutputs <* eof) $-      parserState line name t--commentPrefix :: T.Text-commentPrefix = T.pack "--"- couldNotRead :: IOError -> IO (Either String a) couldNotRead = return . Left . show +pProgramTest :: Parser ProgramTest+pProgramTest = do+  void $ many pNonTestLine+  maybe_spec <- optional testSpec <* pEndOfTestBlock <* many pNonTestLine+  case maybe_spec of+    Just spec+      | RunCases old_cases structures warnings <- testAction spec -> do+        cases <- many $ pInputOutputs <* many pNonTestLine+        pure spec {testAction = RunCases (old_cases ++ concat cases) structures warnings}+      | otherwise ->+        many pNonTestLine *> notFollowedBy "-- ==" *> pure spec+          <?> "no more test blocks, since first test block specifies type error."+    Nothing ->+      eof $> noTest+  where+    noTest =+      ProgramTest mempty mempty (RunCases mempty mempty mempty)++    pEndOfTestBlock =+      (void eol <|> eof) *> notFollowedBy "--"+    pNonTestLine =+      void $ notFollowedBy "-- ==" *> restOfLine+    pInputOutputs =+      parseDescription *> parseInputOutputs <* pEndOfTestBlock+ -- | Read the test specification from the given Futhark program. testSpecFromFile :: FilePath -> IO (Either String ProgramTest)-testSpecFromFile path = do-  blocks_or_err <--    (Right . testBlocks <$> T.readFile path)-      `catch` couldNotRead-  case blocks_or_err of-    Left err -> return $ Left err-    Right blocks -> do-      let (first_spec_line, first_spec, rest_specs) =-            case blocks of-              [] -> (0, mempty, [])-              (n, s) : ss -> (n, s, ss)-      case readTestSpec (1 + first_spec_line) path first_spec of-        Left err -> return $ Left $ errorBundlePretty err-        Right v -> return $ foldM moreCases v rest_specs-  where-    moreCases test (lineno, cases) =-      case readInputOutputs lineno path cases of-        Left err -> Left $ errorBundlePretty err-        Right cases' ->-          case testAction test of-            RunCases old_cases structures warnings ->-              Right test {testAction = RunCases (old_cases ++ cases') structures warnings}-            _ -> Left "Secondary test block provided, but primary test block specifies compilation error."+testSpecFromFile path =+  ( either (Left . errorBundlePretty) Right . parse pProgramTest path+      <$> T.readFile path+  )+    `catch` couldNotRead  -- | Like 'testSpecFromFile', but kills the process on error. testSpecFromFileOrDie :: FilePath -> IO ProgramTest@@ -531,28 +424,6 @@       exitFailure     Right spec -> return spec -testBlocks :: T.Text -> [(Int, T.Text)]-testBlocks = mapMaybe isTestBlock . commentBlocks-  where-    isTestBlock (n, block)-      | any ((" " <> descriptionSeparator) `T.isPrefixOf`) block =-        Just (n, T.unlines block)-      | otherwise =-        Nothing--commentBlocks :: T.Text -> [(Int, [T.Text])]-commentBlocks = commentBlocks' . zip [0 ..] . T.lines-  where-    isComment = (commentPrefix `T.isPrefixOf`)-    commentBlocks' ls =-      let ls' = dropWhile (not . isComment . snd) ls-       in case ls' of-            [] -> []-            (n, _) : _ ->-              let (block, ls'') = span (isComment . snd) ls'-                  block' = map (T.drop 2 . snd) block-               in (n, block') : commentBlocks' ls''- -- | Read test specifications from the given path, which can be a file -- or directory containing @.fut@ files and further directories. testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)])@@ -641,6 +512,24 @@ getValuesBS futhark dir (GenValues gens) =   mconcat <$> mapM (getGenBS futhark dir) gens +-- | Evaluate an IO action while the values are available in a file by+-- some name.  The file will be removed after the action is done.+withValuesFile ::+  MonadIO m =>+  FutharkExe ->+  FilePath ->+  Values ->+  (FilePath -> IO a) ->+  m a+withValuesFile _ dir (InFile file) f+  | takeExtension file /= ".gz" =+    liftIO $ f $ dir </> file+withValuesFile futhark dir vs f =+  liftIO . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do+    BS.hPutStr tmpf_h =<< getValuesBS futhark dir vs+    hClose tmpf_h+    f tmpf+ -- | There is a risk of race conditions when multiple programs have -- identical 'GenValues'.  In such cases, multiple threads in 'futhark -- test' might attempt to create the same file (or read from it, while@@ -695,7 +584,7 @@ genFileSize = genSize   where     header_size = 1 + 1 + 1 + 4 -- 'b' <version> <num_dims> <type>-    genSize (GenValue ds t) =+    genSize (GenValue (ValueType ds t)) =       header_size + toInteger (length ds) * 8         + product (map toInteger ds) * primSize t     genSize (GenPrim v) =@@ -788,14 +677,13 @@ -- the Python backends).  The @extra_options@ are passed to the -- program. runProgram ::-  MonadIO m =>   FutharkExe ->   FilePath ->   [String] ->   String ->   T.Text ->   Values ->-  m (ExitCode, SBS.ByteString, SBS.ByteString)+  IO (ExitCode, SBS.ByteString, SBS.ByteString) runProgram futhark runner extra_options prog entry input = do   let progbin = binaryName prog       dir = takeDirectory prog@@ -809,6 +697,29 @@   input' <- getValuesBS futhark dir input   liftIO $ readProcessWithExitCode to_run to_run_args $ BS.toStrict input' +-- | Read the given variables from a running server.+readResults ::+  (MonadIO m, MonadError T.Text m) =>+  Server ->+  [VarName] ->+  FilePath ->+  m [Value]+readResults server outs program =+  join . liftIO . withSystemTempFile "futhark-output" $ \outputf outputh -> do+    hClose outputh+    store_r <- cmdStore server outputf outs+    case store_r of+      Just (CmdFailure _ err) ->+        pure $ throwError $ T.unlines err+      Nothing -> do+        bytes <- BS.readFile outputf+        case valuesFromByteString "output" bytes of+          Left e -> do+            let actualf = program `addExtension` "actual"+            liftIO $ BS.writeFile actualf bytes+            pure $ throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")"+          Right vs -> pure $ pure vs+ -- | Ensure that any reference output files exist, or create them (by -- compiling the program with the reference compiler and running it on -- the input) if necessary.@@ -874,3 +785,28 @@           " (using " <> takeFileName (program <.> ext) <> ")"         )     else return ([], mempty)++-- | Check that the result is as expected, and write files and throw+-- an error if not.+checkResult ::+  (MonadError T.Text m, MonadIO m) =>+  FilePath ->+  [Value] ->+  [Value] ->+  m ()+checkResult program expected_vs actual_vs =+  case compareValues actual_vs expected_vs of+    mismatch : mismatches -> do+      let actualf = program <.> "actual"+          expectedf = program <.> "expected"+      liftIO $ BS.writeFile actualf $ mconcat $ map Bin.encode actual_vs+      liftIO $ BS.writeFile expectedf $ mconcat $ map Bin.encode expected_vs+      throwError $+        T.pack actualf <> " and " <> T.pack expectedf+          <> " do not match:\n"+          <> T.pack (show mismatch)+          <> if null mismatches+            then mempty+            else "\n...and " <> prettyText (length mismatches) <> " other mismatches."+    [] ->+      return ()