diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -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 ------------ diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -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. diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -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 diff --git a/docs/man/futhark-c.rst b/docs/man/futhark-c.rst --- a/docs/man/futhark-c.rst +++ b/docs/man/futhark-c.rst @@ -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 diff --git a/docs/man/futhark-cuda.rst b/docs/man/futhark-cuda.rst --- a/docs/man/futhark-cuda.rst +++ b/docs/man/futhark-cuda.rst @@ -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 diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-literate.rst @@ -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: `` + + * ``fps: `` + + * ``format: `` + + 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 `` + + The same as the given *directive* (which must not start with another + ``>``), but suppress parameters when printing it. + +* ``> :covert `` + + 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)` diff --git a/docs/man/futhark-multicore.rst b/docs/man/futhark-multicore.rst --- a/docs/man/futhark-multicore.rst +++ b/docs/man/futhark-multicore.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 diff --git a/docs/man/futhark-opencl.rst b/docs/man/futhark-opencl.rst --- a/docs/man/futhark-opencl.rst +++ b/docs/man/futhark-opencl.rst @@ -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 diff --git a/docs/man/futhark-pyopencl.rst b/docs/man/futhark-pyopencl.rst --- a/docs/man/futhark-pyopencl.rst +++ b/docs/man/futhark-pyopencl.rst @@ -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 diff --git a/docs/man/futhark-python.rst b/docs/man/futhark-python.rst --- a/docs/man/futhark-python.rst +++ b/docs/man/futhark-python.rst @@ -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 diff --git a/docs/man/futhark-test.rst b/docs/man/futhark-test.rst --- a/docs/man/futhark-test.rst +++ b/docs/man/futhark-test.rst @@ -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 == diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -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)` diff --git a/docs/server-protocol.rst b/docs/server-protocol.rst new file mode 100644 --- /dev/null +++ b/docs/server-protocol.rst @@ -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`. diff --git a/docs/usage.rst b/docs/usage.rst --- a/docs/usage.rst +++ b/docs/usage.rst @@ -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`` diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -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) diff --git a/rts/c/cuda.h b/rts/c/cuda.h --- a/rts/c/cuda.h +++ b/rts/c/cuda.h @@ -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. diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -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; diff --git a/rts/c/server.h b/rts/c/server.h new file mode 100644 --- /dev/null +++ b/rts/c/server.h @@ -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. diff --git a/rts/python/server.py b/rts/python/server.py new file mode 100644 --- /dev/null +++ b/rts/python/server.py @@ -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 diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -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"] diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -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 diff --git a/src/Futhark/Analysis/Metrics/Type.hs b/src/Futhark/Analysis/Metrics/Type.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Analysis/Metrics/Type.hs @@ -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, "")] diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -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 diff --git a/src/Futhark/Analysis/Rephrase.hs b/src/Futhark/Analysis/Rephrase.hs --- a/src/Futhark/Analysis/Rephrase.hs +++ b/src/Futhark/Analysis/Rephrase.hs @@ -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. diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Futhark.Analysis.SymbolTable ( SymbolTable (bindings, loopDepth, availableAtClosestLoop, simplifyMemory), diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -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 ) "" diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs --- a/src/Futhark/CLI/Autotune.hs +++ b/src/Futhark/CLI/Autotune.hs @@ -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 diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -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 = diff --git a/src/Futhark/CLI/Check.hs b/src/Futhark/CLI/Check.hs --- a/src/Futhark/CLI/Check.hs +++ b/src/Futhark/CLI/Check.hs @@ -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} diff --git a/src/Futhark/CLI/Dataset.hs b/src/Futhark/CLI/Dataset.hs --- a/src/Futhark/CLI/Dataset.hs +++ b/src/Futhark/CLI/Dataset.hs @@ -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 diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -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 $ diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs --- a/src/Futhark/CLI/Doc.hs +++ b/src/Futhark/CLI/Doc.hs @@ -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 diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Literate.hs @@ -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 diff --git a/src/Futhark/CLI/Multicore.hs b/src/Futhark/CLI/Multicore.hs --- a/src/Futhark/CLI/Multicore.hs +++ b/src/Futhark/CLI/Multicore.hs @@ -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 () diff --git a/src/Futhark/CLI/Pkg.hs b/src/Futhark/CLI/Pkg.hs --- a/src/Futhark/CLI/Pkg.hs +++ b/src/Futhark/CLI/Pkg.hs @@ -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 diff --git a/src/Futhark/CLI/PyOpenCL.hs b/src/Futhark/CLI/PyOpenCL.hs --- a/src/Futhark/CLI/PyOpenCL.hs +++ b/src/Futhark/CLI/PyOpenCL.hs @@ -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 diff --git a/src/Futhark/CLI/Python.hs b/src/Futhark/CLI/Python.hs --- a/src/Futhark/CLI/Python.hs +++ b/src/Futhark/CLI/Python.hs @@ -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 diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -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)) ) diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs --- a/src/Futhark/CLI/Run.hs +++ b/src/Futhark/CLI/Run.hs @@ -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)) ) diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -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" }, diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -7,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);|]] diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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)); + }|] diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -8,6 +8,7 @@ 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]);|]] diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -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 ") $esc:("#include ") $esc:("#include ") +$esc:("#include ") $esc:("#include ") $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 ") -$esc:("#include ") -$esc:("#include ") +$esc:("#include ") $esc:("#include ") $esc:("#include ") @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs --- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs @@ -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 ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") $esc:("#include ") +$esc:("#include ") +$esc:("#include ") $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]); diff --git a/src/Futhark/CodeGen/Backends/GenericC/Server.hs b/src/Futhark/CodeGen/Backends/GenericC/Server.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/GenericC/Server.hs @@ -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 ") +$esc:("#include ") +$esc:("#include ") + +// 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); +} +|] diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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 = diff --git a/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs b/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs --- a/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs @@ -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") diff --git a/src/Futhark/CodeGen/Backends/MulticoreC.hs b/src/Futhark/CodeGen/Backends/MulticoreC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreC.hs @@ -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), diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SequentialC.hs b/src/Futhark/CodeGen/Backends/SequentialC.hs --- a/src/Futhark/CodeGen/Backends/SequentialC.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC.hs @@ -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; diff --git a/src/Futhark/CodeGen/Backends/SequentialPython.hs b/src/Futhark/CodeGen/Backends/SequentialPython.hs --- a/src/Futhark/CodeGen/Backends/SequentialPython.hs +++ b/src/Futhark/CodeGen/Backends/SequentialPython.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs --- a/src/Futhark/CodeGen/Backends/SimpleRep.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -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' + 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));|] diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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 $ diff --git a/src/Futhark/CodeGen/ImpGen/CUDA.hs b/src/Futhark/CodeGen/ImpGen/CUDA.hs --- a/src/Futhark/CodeGen/ImpGen/CUDA.hs +++ b/src/Futhark/CodeGen/ImpGen/CUDA.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore.hs b/src/Futhark/CodeGen/ImpGen/Multicore.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore.hs @@ -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, diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs @@ -1,3 +1,4 @@ +-- | Multicore code generation for 'SegMap'. module Futhark.CodeGen.ImpGen.Multicore.SegMap ( compileSegMap, ) diff --git a/src/Futhark/CodeGen/ImpGen/OpenCL.hs b/src/Futhark/CodeGen/ImpGen/OpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/OpenCL.hs @@ -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 diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -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 diff --git a/src/Futhark/Compiler/CLI.hs b/src/Futhark/Compiler/CLI.hs --- a/src/Futhark/Compiler/CLI.hs +++ b/src/Futhark/Compiler/CLI.hs @@ -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 } diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -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) = diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} -- | = Constructing Futhark ASTs diff --git a/src/Futhark/Error.hs b/src/Futhark/Error.hs --- a/src/Futhark/Error.hs +++ b/src/Futhark/Error.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} -- | Futhark error definitions. module Futhark.Error diff --git a/src/Futhark/IR.hs b/src/Futhark/IR.hs --- a/src/Futhark/IR.hs +++ b/src/Futhark/IR.hs @@ -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 diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs --- a/src/Futhark/IR/Mem.hs +++ b/src/Futhark/IR/Mem.hs @@ -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 $ diff --git a/src/Futhark/IR/Mem/IxFun.hs b/src/Futhark/IR/Mem/IxFun.hs --- a/src/Futhark/IR/Mem/IxFun.hs +++ b/src/Futhark/IR/Mem/IxFun.hs @@ -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 diff --git a/src/Futhark/IR/Primitive.hs b/src/Futhark/IR/Primitive.hs --- a/src/Futhark/IR/Primitive.hs +++ b/src/Futhark/IR/Primitive.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} -- | Definitions of primitive types, the values that inhabit these diff --git a/src/Futhark/IR/Prop.hs b/src/Futhark/IR/Prop.hs --- a/src/Futhark/IR/Prop.hs +++ b/src/Futhark/IR/Prop.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} -- | This module provides various simple ways to query and manipulate diff --git a/src/Futhark/IR/Prop/Names.hs b/src/Futhark/IR/Prop/Names.hs --- a/src/Futhark/IR/Prop/Names.hs +++ b/src/Futhark/IR/Prop/Names.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} -- | Facilities for determining which names are used in some syntactic diff --git a/src/Futhark/IR/Prop/Types.hs b/src/Futhark/IR/Prop/Types.hs --- a/src/Futhark/IR/Prop/Types.hs +++ b/src/Futhark/IR/Prop/Types.hs @@ -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 diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs --- a/src/Futhark/IR/SOACS.hs +++ b/src/Futhark/IR/SOACS.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} -- | A simple representation with SOACs and nested parallelism. diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs --- a/src/Futhark/IR/SOACS/Simplify.hs +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.IR.SOACS.Simplify diff --git a/src/Futhark/IR/Syntax/Core.hs b/src/Futhark/IR/Syntax/Core.hs --- a/src/Futhark/IR/Syntax/Core.hs +++ b/src/Futhark/IR/Syntax/Core.hs @@ -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 diff --git a/src/Futhark/IR/Traversals.hs b/src/Futhark/IR/Traversals.hs --- a/src/Futhark/IR/Traversals.hs +++ b/src/Futhark/IR/Traversals.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - -- | -- -- Functions for generic traversals across Futhark syntax trees. The diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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 = diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} -- | Internalising bindings. module Futhark.Internalise.Bindings diff --git a/src/Futhark/Internalise/LiftLambdas.hs b/src/Futhark/Internalise/LiftLambdas.hs --- a/src/Futhark/Internalise/LiftLambdas.hs +++ b/src/Futhark/Internalise/LiftLambdas.hs @@ -168,6 +168,8 @@ addValBind $ vb {valBindBody = e} {-# NOINLINE transformProg #-} + +-- | Perform the transformation. transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] transformProg vbinds = modifyNameSource $ \namesrc -> diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -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) <- diff --git a/src/Futhark/Optimise/Simplify/ClosedForm.hs b/src/Futhark/Optimise/Simplify/ClosedForm.hs --- a/src/Futhark/Optimise/Simplify/ClosedForm.hs +++ b/src/Futhark/Optimise/Simplify/ClosedForm.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -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 _) = diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -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 diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -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 $ diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -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 () diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -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. diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Script.hs @@ -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 diff --git a/src/Futhark/Server.hs b/src/Futhark/Server.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Server.hs @@ -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"] diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -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' - 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 () diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs --- a/src/Futhark/Test/Values.hs +++ b/src/Futhark/Test/Values.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} {-# LANGUAGE Trustworthy #-} @@ -10,6 +11,8 @@ -- for your test programs. module Futhark.Test.Values ( Value (..), + Compound (..), + CompoundValue, Vector, -- * Reading Values @@ -18,11 +21,20 @@ -- * Types of values ValueType (..), valueType, + valueShape, + -- * Manipulating values + valueElems, + mkCompound, + -- * Comparing Values compareValues, compareValues1, Mismatch, + + -- * Converting values + GetValue (..), + PutValue (..), ) where @@ -31,14 +43,18 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put -import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (chr, isSpace, ord) import Data.Int (Int16, Int32, Int64, Int8) -import Data.Vector.Binary +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Traversable import Data.Vector.Generic (freeze) +import qualified Data.Vector.Storable as SVec +import Data.Vector.Storable.ByteString (byteStringToVector, vectorToByteString) import qualified Data.Vector.Unboxed as UVec import qualified Data.Vector.Unboxed.Mutable as UMVec -import Futhark.IR.Pretty () import Futhark.IR.Primitive (PrimValue) import Futhark.IR.Prop.Constants (IsValue (..)) import Futhark.Util (maybeHead) @@ -51,8 +67,8 @@ type STVector s = UMVec.STVector s --- | An Unboxed vector. -type Vector = UVec.Vector +-- | The value vector type. +type Vector = SVec.Vector -- | An efficiently represented Futhark value. Use 'pretty' to get a -- human-readable representation, and v'put' to obtain binary a @@ -75,20 +91,22 @@ binaryFormatVersion = 2 instance Binary Value where - put (Int8Value shape vs) = putBinaryValue " i8" shape vs putInt8 - put (Int16Value shape vs) = putBinaryValue " i16" shape vs putInt16le - put (Int32Value shape vs) = putBinaryValue " i32" shape vs putInt32le - put (Int64Value shape vs) = putBinaryValue " i64" shape vs putInt64le - put (Word8Value shape vs) = putBinaryValue " u8" shape vs putWord8 - put (Word16Value shape vs) = putBinaryValue " u16" shape vs putWord16le - put (Word32Value shape vs) = putBinaryValue " u32" shape vs putWord32le - put (Word64Value shape vs) = putBinaryValue " u64" shape vs putWord64le - put (Float32Value shape vs) = putBinaryValue " f32" shape vs putFloatle - put (Float64Value shape vs) = putBinaryValue " f64" shape vs putDoublele - put (BoolValue shape vs) = putBinaryValue "bool" shape vs $ putInt8 . boolToInt + put (Int8Value shape vs) = putBinaryValue " i8" shape vs + put (Int16Value shape vs) = putBinaryValue " i16" shape vs + put (Int32Value shape vs) = putBinaryValue " i32" shape vs + put (Int64Value shape vs) = putBinaryValue " i64" shape vs + put (Word8Value shape vs) = putBinaryValue " u8" shape vs + put (Word16Value shape vs) = putBinaryValue " u16" shape vs + put (Word32Value shape vs) = putBinaryValue " u32" shape vs + put (Word64Value shape vs) = putBinaryValue " u64" shape vs + put (Float32Value shape vs) = putBinaryValue " f32" shape vs + put (Float64Value shape vs) = putBinaryValue " f64" shape vs + -- Bool must be treated specially because the Storable instance + -- uses four bytes. + put (BoolValue shape vs) = putBinaryValue "bool" shape $ SVec.map boolToInt8 vs where - boolToInt True = 1 - boolToInt False = 0 + boolToInt8 True = 1 :: Int8 + boolToInt8 False = 0 get = do first <- getInt8 @@ -106,41 +124,45 @@ shape <- replicateM (fromIntegral rank) $ fromIntegral <$> getInt64le let num_elems = product shape - shape' = UVec.fromList shape + shape' = SVec.fromList shape - case BS.unpack type_f of - " i8" -> get' (Int8Value shape') getInt8 num_elems - " i16" -> get' (Int16Value shape') getInt16le num_elems - " i32" -> get' (Int32Value shape') getInt32le num_elems - " i64" -> get' (Int64Value shape') getInt64le num_elems - " u8" -> get' (Word8Value shape') getWord8 num_elems - " u16" -> get' (Word16Value shape') getWord16le num_elems - " u32" -> get' (Word32Value shape') getWord32le num_elems - " u64" -> get' (Word64Value shape') getWord64le num_elems - " f32" -> get' (Float32Value shape') getFloatle num_elems - " f64" -> get' (Float64Value shape') getDoublele num_elems - "bool" -> get' (BoolValue shape') getBool num_elems + case LBS.unpack type_f of + " i8" -> get' (Int8Value shape') num_elems 1 + " i16" -> get' (Int16Value shape') num_elems 2 + " i32" -> get' (Int32Value shape') num_elems 4 + " i64" -> get' (Int64Value shape') num_elems 8 + " u8" -> get' (Word8Value shape') num_elems 1 + " u16" -> get' (Word16Value shape') num_elems 2 + " u32" -> get' (Word32Value shape') num_elems 4 + " u64" -> get' (Word64Value shape') num_elems 8 + " f32" -> get' (Float32Value shape') num_elems 4 + " f64" -> get' (Float64Value shape') num_elems 8 + -- Bool must be treated specially because the Storable instance + -- uses four bytes. + "bool" -> BoolValue shape' . SVec.map int8ToBool . byteStringToVector . BS.copy <$> getByteString num_elems s -> fail $ "Cannot parse binary values of type " ++ show s where - getBool = (/= 0) <$> getWord8 + -- The copy is to ensure that the bytestring is properly + -- aligned. + get' mk num_elems elem_size = + mk . byteStringToVector . BS.copy <$> getByteString (num_elems * elem_size) - get' mk get_elem num_elems = - mk <$> genericGetVectorWith (pure num_elems) get_elem + int8ToBool :: Int8 -> Bool + int8ToBool = (/= 0) putBinaryValue :: - UVec.Unbox a => + SVec.Storable a => String -> Vector Int -> Vector a -> - (a -> Put) -> Put -putBinaryValue tstr shape vs putv = do +putBinaryValue tstr shape vs = do putInt8 $ fromIntegral $ ord 'b' putWord8 binaryFormatVersion - putWord8 $ fromIntegral $ UVec.length shape + putWord8 $ fromIntegral $ SVec.length shape mapM_ (putInt8 . fromIntegral . ord) tstr - mapM_ (putInt64le . fromIntegral) $ UVec.toList shape - mapM_ putv $ UVec.toList vs + putByteString $ vectorToByteString shape + putByteString $ vectorToByteString vs instance PP.Pretty Value where ppr v @@ -149,41 +171,77 @@ <> parens (dims <> ppr (valueElemType v)) where dims = mconcat $ map (brackets . ppr) $ valueShape v - ppr (Int8Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Int16Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Int32Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Int64Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Word8Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Word16Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Word32Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Word64Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Float32Value shape vs) = pprArray (UVec.toList shape) vs - ppr (Float64Value shape vs) = pprArray (UVec.toList shape) vs - ppr (BoolValue shape vs) = pprArray (UVec.toList shape) vs + ppr (Int8Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Int16Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Int32Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Int64Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Word8Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Word16Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Word32Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Word64Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Float32Value shape vs) = pprArray (SVec.toList shape) vs + ppr (Float64Value shape vs) = pprArray (SVec.toList shape) vs + ppr (BoolValue shape vs) = pprArray (SVec.toList shape) vs -pprArray :: (UVec.Unbox a, F.IsPrimValue a) => [Int] -> UVec.Vector a -> Doc +pprArray :: (SVec.Storable a, F.IsPrimValue a) => [Int] -> SVec.Vector a -> Doc pprArray [] vs = - ppr $ F.primValue $ UVec.head vs + ppr $ F.primValue $ SVec.head vs pprArray (d : ds) vs = brackets $ cat $ punctuate separator $ map (pprArray ds . slice) [0 .. d -1] where slice_size = product ds - slice i = UVec.slice (i * slice_size) slice_size vs + slice i = SVec.slice (i * slice_size) slice_size vs separator | null ds = comma <> space | otherwise = comma <> line +-- | The structure of a compound value, parameterised over the actual +-- values. For most cases you probably want 'CompoundValue'. +data Compound v + = ValueRecord (M.Map T.Text (Compound v)) + | -- | Must not be single value. + ValueTuple [Compound v] + | ValueAtom v + deriving (Eq, Ord, Show) + +instance Functor Compound where + fmap = fmapDefault + +instance Foldable Compound where + foldMap = foldMapDefault + +instance Traversable Compound where + traverse f (ValueAtom v) = ValueAtom <$> f v + traverse f (ValueTuple vs) = ValueTuple <$> traverse (traverse f) vs + traverse f (ValueRecord m) = ValueRecord <$> traverse (traverse f) m + +instance Pretty v => Pretty (Compound v) where + ppr (ValueAtom v) = ppr v + ppr (ValueTuple vs) = parens $ commasep $ map ppr vs + ppr (ValueRecord m) = braces $ commasep $ map field $ M.toList m + where + field (k, v) = ppr k <> equals <> ppr v + +-- | Create a tuple for a non-unit list, and otherwise a 'ValueAtom' +mkCompound :: [v] -> Compound v +mkCompound [v] = ValueAtom v +mkCompound vs = ValueTuple $ map ValueAtom vs + +-- | Like a 'Value', but also grouped in compound ways that are not +-- supported by raw values. You cannot parse or read these in +-- standard ways, and they cannot be elements of arrays. +type CompoundValue = Compound Value + -- | A representation of the simple values we represent in this module. data ValueType = ValueType [Int] F.PrimType - deriving (Show) + deriving (Eq, Ord, Show) instance PP.Pretty ValueType where ppr (ValueType ds t) = mconcat (map pprDim ds) <> ppr t where pprDim d = brackets $ ppr d --- | A textual description of the type of a value. Follows Futhark --- type notation, and contains the exact dimension sizes if an array. +-- | Get the type of a value. valueType :: Value -> ValueType valueType v = ValueType (valueShape v) $ valueElemType v @@ -200,42 +258,71 @@ valueElemType Float64Value {} = F.FloatType F.Float64 valueElemType BoolValue {} = F.Bool +-- | The shape of a value. Empty list in case of a scalar. valueShape :: Value -> [Int] -valueShape (Int8Value shape _) = UVec.toList shape -valueShape (Int16Value shape _) = UVec.toList shape -valueShape (Int32Value shape _) = UVec.toList shape -valueShape (Int64Value shape _) = UVec.toList shape -valueShape (Word8Value shape _) = UVec.toList shape -valueShape (Word16Value shape _) = UVec.toList shape -valueShape (Word32Value shape _) = UVec.toList shape -valueShape (Word64Value shape _) = UVec.toList shape -valueShape (Float32Value shape _) = UVec.toList shape -valueShape (Float64Value shape _) = UVec.toList shape -valueShape (BoolValue shape _) = UVec.toList shape +valueShape (Int8Value shape _) = SVec.toList shape +valueShape (Int16Value shape _) = SVec.toList shape +valueShape (Int32Value shape _) = SVec.toList shape +valueShape (Int64Value shape _) = SVec.toList shape +valueShape (Word8Value shape _) = SVec.toList shape +valueShape (Word16Value shape _) = SVec.toList shape +valueShape (Word32Value shape _) = SVec.toList shape +valueShape (Word64Value shape _) = SVec.toList shape +valueShape (Float32Value shape _) = SVec.toList shape +valueShape (Float64Value shape _) = SVec.toList shape +valueShape (BoolValue shape _) = SVec.toList shape +-- | Produce a list of the immediate elements of the value. That is, +-- a 2D array will produce a list of 1D values. While lists are of +-- course inefficient, the actual values are just slices of the +-- original value, which makes them fairly efficient. +valueElems :: Value -> [Value] +valueElems v + | n : ns <- valueShape v = + let k = product ns + slices mk vs = + [ mk (SVec.fromList ns) $ + SVec.slice (k * i) k vs + | i <- [0 .. n -1] + ] + in case v of + Int8Value _ vs -> slices Int8Value vs + Int16Value _ vs -> slices Int16Value vs + Int32Value _ vs -> slices Int32Value vs + Int64Value _ vs -> slices Int64Value vs + Word8Value _ vs -> slices Word8Value vs + Word16Value _ vs -> slices Word16Value vs + Word32Value _ vs -> slices Word32Value vs + Word64Value _ vs -> slices Word64Value vs + Float32Value _ vs -> slices Float32Value vs + Float64Value _ vs -> slices Float64Value vs + BoolValue _ vs -> slices BoolValue vs + | otherwise = + [] + -- The parser -dropRestOfLine, dropSpaces :: BS.ByteString -> BS.ByteString -dropRestOfLine = BS.drop 1 . BS.dropWhile (/= '\n') -dropSpaces t = case BS.dropWhile isSpace t of +dropRestOfLine, dropSpaces :: LBS.ByteString -> LBS.ByteString +dropRestOfLine = LBS.drop 1 . LBS.dropWhile (/= '\n') +dropSpaces t = case LBS.dropWhile isSpace t of t' - | "--" `BS.isPrefixOf` t' -> dropSpaces $ dropRestOfLine t' + | "--" `LBS.isPrefixOf` t' -> dropSpaces $ dropRestOfLine t' | otherwise -> t' -type ReadValue v = BS.ByteString -> Maybe (v, BS.ByteString) +type ReadValue v = LBS.ByteString -> Maybe (v, LBS.ByteString) -symbol :: Char -> BS.ByteString -> Maybe BS.ByteString +symbol :: Char -> LBS.ByteString -> Maybe LBS.ByteString symbol c t - | Just (c', t') <- BS.uncons t, c' == c = Just $ dropSpaces t' + | Just (c', t') <- LBS.uncons t, c' == c = Just $ dropSpaces t' | otherwise = Nothing -lexeme :: BS.ByteString -> BS.ByteString -> Maybe BS.ByteString +lexeme :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString lexeme l t - | l `BS.isPrefixOf` t = Just $ dropSpaces $ BS.drop (BS.length l) t + | l `LBS.isPrefixOf` t = Just $ dropSpaces $ LBS.drop (LBS.length l) t | otherwise = Nothing -- (Used elements, shape, elements, remaining input) -type State s v = (Int, Vector Int, STVector s v, BS.ByteString) +type State s v = (Int, Vector Int, STVector s v, LBS.ByteString) readArrayElemsST :: UMVec.Unbox v => @@ -260,12 +347,12 @@ updateShape :: Int -> Int -> Vector Int -> Maybe (Vector Int) updateShape d n shape - | old_n < 0 = Just $ shape UVec.// [(r - d, n)] + | old_n < 0 = Just $ shape SVec.// [(r - d, n)] | old_n == n = Just shape | otherwise = Nothing where - r = UVec.length shape - old_n = shape UVec.! (r - d) + r = SVec.length shape + old_n = shape SVec.! (r - d) growIfFilled :: UVec.Unbox v => Int -> STVector s v -> ST s (STVector s v) growIfFilled i arr = @@ -302,18 +389,18 @@ return (i, shape', arr, t') readRankedArrayOf :: - UMVec.Unbox v => + (UMVec.Unbox v, SVec.Storable v) => Int -> ReadValue v -> - BS.ByteString -> - Maybe (Vector Int, Vector v, BS.ByteString) + LBS.ByteString -> + Maybe (Vector Int, Vector v, LBS.ByteString) readRankedArrayOf r rv t = runST $ do arr <- UMVec.new 1024 - ms <- readRankedArrayOfST r rv (0, UVec.replicate r (-1), arr, t) + ms <- readRankedArrayOfST r rv (0, SVec.replicate r (-1), arr, t) case ms of Just (i, shape, arr', t') -> do arr'' <- freeze (UMVec.slice 0 i arr') - return $ Just (shape, arr'', t') + return $ Just (shape, UVec.convert arr'', t') Nothing -> return Nothing @@ -335,7 +422,7 @@ _ -> Nothing return (v, dropSpaces b) where - (a, b) = BS.span constituent t + (a, b) = LBS.span constituent t readInt8 :: ReadValue Int8 readInt8 = readIntegral f @@ -395,7 +482,7 @@ _ -> Nothing return (v, dropSpaces b) where - (a, b) = BS.span constituent t + (a, b) = LBS.span constituent t fromDouble = uncurry encodeFloat . decodeFloat unLoc (L _ x) = x @@ -423,7 +510,7 @@ _ -> Nothing return (v, dropSpaces b) where - (a, b) = BS.span constituent t + (a, b) = LBS.span constituent t readPrimType :: ReadValue String readPrimType t = do @@ -432,9 +519,9 @@ _ -> Nothing return (pt, dropSpaces b) where - (a, b) = BS.span constituent t + (a, b) = LBS.span constituent t -readEmptyArrayOfShape :: [Int] -> BS.ByteString -> Maybe (Value, BS.ByteString) +readEmptyArrayOfShape :: [Int] -> LBS.ByteString -> Maybe (Value, LBS.ByteString) readEmptyArrayOfShape shape t | Just t' <- symbol '[' t, Just (d, t'') <- readIntegral (const Nothing) t', @@ -444,28 +531,28 @@ (pt, t') <- readPrimType t guard $ elem 0 shape v <- case pt of - "i8" -> Just $ Int8Value (UVec.fromList shape) UVec.empty - "i16" -> Just $ Int16Value (UVec.fromList shape) UVec.empty - "i32" -> Just $ Int32Value (UVec.fromList shape) UVec.empty - "i64" -> Just $ Int64Value (UVec.fromList shape) UVec.empty - "u8" -> Just $ Word8Value (UVec.fromList shape) UVec.empty - "u16" -> Just $ Word16Value (UVec.fromList shape) UVec.empty - "u32" -> Just $ Word32Value (UVec.fromList shape) UVec.empty - "u64" -> Just $ Word64Value (UVec.fromList shape) UVec.empty - "f32" -> Just $ Float32Value (UVec.fromList shape) UVec.empty - "f64" -> Just $ Float64Value (UVec.fromList shape) UVec.empty - "bool" -> Just $ BoolValue (UVec.fromList shape) UVec.empty + "i8" -> Just $ Int8Value (SVec.fromList shape) SVec.empty + "i16" -> Just $ Int16Value (SVec.fromList shape) SVec.empty + "i32" -> Just $ Int32Value (SVec.fromList shape) SVec.empty + "i64" -> Just $ Int64Value (SVec.fromList shape) SVec.empty + "u8" -> Just $ Word8Value (SVec.fromList shape) SVec.empty + "u16" -> Just $ Word16Value (SVec.fromList shape) SVec.empty + "u32" -> Just $ Word32Value (SVec.fromList shape) SVec.empty + "u64" -> Just $ Word64Value (SVec.fromList shape) SVec.empty + "f32" -> Just $ Float32Value (SVec.fromList shape) SVec.empty + "f64" -> Just $ Float64Value (SVec.fromList shape) SVec.empty + "bool" -> Just $ BoolValue (SVec.fromList shape) SVec.empty _ -> Nothing return (v, t') -readEmptyArray :: BS.ByteString -> Maybe (Value, BS.ByteString) +readEmptyArray :: LBS.ByteString -> Maybe (Value, LBS.ByteString) readEmptyArray t = do t' <- symbol '(' =<< lexeme "empty" t (v, t'') <- readEmptyArrayOfShape [] t' t''' <- symbol ')' t'' return (v, t''') -readValue :: BS.ByteString -> Maybe (Value, BS.ByteString) +readValue :: LBS.ByteString -> Maybe (Value, LBS.ByteString) readValue full_t | Right (t', _, v) <- decodeOrFail full_t = Just (v, dropSpaces t') @@ -493,11 +580,11 @@ `mplus` tryWith readBool BoolValue r t -- | Parse Futhark values from the given bytestring. -readValues :: BS.ByteString -> Maybe [Value] +readValues :: LBS.ByteString -> Maybe [Value] readValues = readValues' . dropSpaces where readValues' t - | BS.null t = Just [] + | LBS.null t = Just [] | otherwise = do (a, t') <- readValue t (a :) <$> readValues' t' @@ -574,28 +661,45 @@ | otherwise = [ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v)] where + {-# INLINE compareGen #-} + {-# INLINE compareNum #-} + {-# INLINE compareFloat #-} + {-# INLINE compareFloatElement #-} + {-# INLINE compareElement #-} compareNum tol = compareGen $ compareElement tol compareFloat tol = compareGen $ compareFloatElement tol compareGen cmp got expected = - concat $ - zipWith cmp (UVec.toList $ UVec.indexed got) (UVec.toList expected) + let l = SVec.length got + check acc j + | j < l = + case cmp j (got SVec.! j) (expected SVec.! j) of + Just mismatch -> + check (mismatch : acc) (j + 1) + Nothing -> + check acc (j + 1) + | otherwise = + acc + in reverse $ check [] 0 - compareElement tol (j, got) expected - | comparePrimValue tol got expected = [] - | otherwise = [PrimValueMismatch (i, j) (value got) (value expected)] + compareElement tol j got expected + | comparePrimValue tol got expected = Nothing + | otherwise = Just $ PrimValueMismatch (i, j) (value got) (value expected) - compareFloatElement tol (j, got) expected - | isNaN got, isNaN expected = [] + compareFloatElement tol j got expected + | isNaN got, + isNaN expected = + Nothing | isInfinite got, isInfinite expected, signum got == signum expected = - [] - | otherwise = compareElement tol (j, got) expected + Nothing + | otherwise = + compareElement tol j got expected - compareBool (j, got) expected - | got == expected = [] - | otherwise = [PrimValueMismatch (i, j) (value got) (value expected)] + compareBool j got expected + | got == expected = Nothing + | otherwise = Just $ PrimValueMismatch (i, j) (value got) (value expected) comparePrimValue :: (Ord num, Num num) => @@ -611,8 +715,103 @@ minTolerance :: Fractional a => a minTolerance = 0.002 -- 0.2% -tolerance :: (RealFloat a, UVec.Unbox a) => Vector a -> a -tolerance = UVec.foldl tolerance' minTolerance . UVec.filter (not . nanOrInf) +tolerance :: (RealFloat a, SVec.Storable a) => Vector a -> a +tolerance = SVec.foldl tolerance' minTolerance . SVec.filter (not . nanOrInf) where tolerance' t v = max t $ minTolerance * v nanOrInf x = isInfinite x || isNaN x + +-- | A class for Haskell values that can be retrieved from 'Value'. +-- This is a convenience facility - don't expect it to be fast. +class GetValue t where + getValue :: Value -> Maybe t + +instance GetValue Bool where + getValue (BoolValue shape vs) + | [] <- SVec.toList shape = + Just $ vs SVec.! 0 + getValue _ = Nothing + +instance GetValue Int8 where + getValue (Int8Value shape vs) + | [] <- SVec.toList shape = + Just $ vs SVec.! 0 + getValue _ = Nothing + +instance GetValue Int16 where + getValue (Int16Value shape vs) + | [] <- SVec.toList shape = + Just $ vs SVec.! 0 + getValue _ = Nothing + +instance GetValue Int32 where + getValue (Int32Value shape vs) + | [] <- SVec.toList shape = + Just $ vs SVec.! 0 + getValue _ = Nothing + +instance GetValue Int64 where + getValue (Int64Value shape vs) + | [] <- SVec.toList shape = + Just $ vs SVec.! 0 + getValue _ = Nothing + +-- | A class for Haskell values that can be converted to 'Value'. +-- This is a convenience facility - don't expect it to be fast. +class PutValue t where + -- | This may fail for cases such as irregular arrays. + putValue :: t -> Maybe Value + +instance PutValue F.PrimValue where + putValue (F.SignedValue (F.Int8Value x)) = + Just $ Int8Value mempty $ SVec.singleton x + putValue (F.SignedValue (F.Int16Value x)) = + Just $ Int16Value mempty $ SVec.singleton x + putValue (F.SignedValue (F.Int32Value x)) = + Just $ Int32Value mempty $ SVec.singleton x + putValue (F.SignedValue (F.Int64Value x)) = + Just $ Int64Value mempty $ SVec.singleton x + putValue (F.UnsignedValue (F.Int8Value x)) = + Just $ Word8Value mempty $ SVec.singleton $ fromIntegral x + putValue (F.UnsignedValue (F.Int16Value x)) = + Just $ Word16Value mempty $ SVec.singleton $ fromIntegral x + putValue (F.UnsignedValue (F.Int32Value x)) = + Just $ Word32Value mempty $ SVec.singleton $ fromIntegral x + putValue (F.UnsignedValue (F.Int64Value x)) = + Just $ Word64Value mempty $ SVec.singleton $ fromIntegral x + putValue (F.FloatValue (F.Float32Value x)) = + Just $ Float32Value mempty $ SVec.singleton x + putValue (F.FloatValue (F.Float64Value x)) = + Just $ Float64Value mempty $ SVec.singleton x + putValue (F.BoolValue b) = + Just $ BoolValue mempty $ SVec.singleton b + +instance PutValue [Value] where + putValue [] = Nothing + putValue (x : xs) = do + let res_shape = SVec.fromList $ length (x : xs) : valueShape x + guard $ all ((== valueType x) . valueType) xs + Just $ case x of + Int8Value {} -> Int8Value res_shape $ foldMap getVec (x : xs) + Int16Value {} -> Int16Value res_shape $ foldMap getVec (x : xs) + Int32Value {} -> Int32Value res_shape $ foldMap getVec (x : xs) + Int64Value {} -> Int64Value res_shape $ foldMap getVec (x : xs) + Word8Value {} -> Word8Value res_shape $ foldMap getVec (x : xs) + Word16Value {} -> Word16Value res_shape $ foldMap getVec (x : xs) + Word32Value {} -> Word32Value res_shape $ foldMap getVec (x : xs) + Word64Value {} -> Word64Value res_shape $ foldMap getVec (x : xs) + Float32Value {} -> Float32Value res_shape $ foldMap getVec (x : xs) + Float64Value {} -> Float64Value res_shape $ foldMap getVec (x : xs) + BoolValue {} -> BoolValue res_shape $ foldMap getVec (x : xs) + where + getVec (Int8Value _ vec) = SVec.unsafeCast vec + getVec (Int16Value _ vec) = SVec.unsafeCast vec + getVec (Int32Value _ vec) = SVec.unsafeCast vec + getVec (Int64Value _ vec) = SVec.unsafeCast vec + getVec (Word8Value _ vec) = SVec.unsafeCast vec + getVec (Word16Value _ vec) = SVec.unsafeCast vec + getVec (Word32Value _ vec) = SVec.unsafeCast vec + getVec (Word64Value _ vec) = SVec.unsafeCast vec + getVec (Float32Value _ vec) = SVec.unsafeCast vec + getVec (Float64Value _ vec) = SVec.unsafeCast vec + getVec (BoolValue _ vec) = SVec.unsafeCast vec diff --git a/src/Futhark/Test/Values/Parser.hs b/src/Futhark/Test/Values/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Test/Values/Parser.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Megaparsec-based parser for primitive 'Value's. The difference +-- between this and the parser defined in "Futhark.Test.Values" is +-- that we don't try to handle both the textual and binary format - +-- only the former. On the other hand, this parser has (much) better +-- error messages and can be easily used by other parsers (like the +-- ones for FutharkScript or test blocks. +module Futhark.Test.Values.Parser + ( parsePrimType, + parseType, + parsePrimValue, + parseValue, + ) +where + +import Control.Monad.Except +import Data.Functor +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector.Storable as SVec +import Data.Void +import Futhark.Test.Values +import qualified Language.Futhark.Syntax as F +import Text.Megaparsec +import Text.Megaparsec.Char.Lexer + ( binary, + decimal, + float, + hexadecimal, + signed, + ) + +type Parser = Parsec Void T.Text + +-- | Parse the name of a primitive type. Does *not* consume any +-- trailing whitespace, nor does it permit any internal whitespace. +parsePrimType :: Parser F.PrimType +parsePrimType = + choice + [ "i8" $> F.Signed F.Int8, + "i16" $> F.Signed F.Int16, + "i32" $> F.Signed F.Int32, + "i64" $> F.Signed F.Int64, + "u8" $> F.Unsigned F.Int8, + "u16" $> F.Unsigned F.Int16, + "u32" $> F.Unsigned F.Int32, + "u64" $> F.Unsigned F.Int64, + "f32" $> F.FloatType F.Float32, + "f64" $> F.FloatType F.Float64, + "bool" $> F.Bool + ] + +parseInteger :: Parser Integer +parseInteger = + signed (pure ()) $ + choice + [ "0b" *> binary, + "0x" *> hexadecimal, + decimal + ] + +parseIntConst :: Parser F.PrimValue +parseIntConst = do + x <- parseInteger + notFollowedBy $ "f32" <|> "f64" <|> "." + choice + [ signedV F.Int8Value x "i8", + signedV F.Int16Value x "i16", + signedV F.Int32Value x "i32", + signedV F.Int64Value x "i64", + unsignedV F.Int8Value x "u8", + unsignedV F.Int16Value x "u16", + unsignedV F.Int32Value x "u32", + unsignedV F.Int64Value x "u64", + signedV F.Int32Value x "" + ] + where + signedV mk x suffix = + suffix $> F.SignedValue (mk (fromInteger x)) + unsignedV mk x suffix = + suffix $> F.UnsignedValue (mk (fromInteger x)) + +parseFloatConst :: Parser F.PrimValue +parseFloatConst = + choice + [ "f32.nan" $> F.FloatValue (F.Float32Value (0 / 0)), + "f64.nan" $> F.FloatValue (F.Float64Value (0 / 0)), + "f32.inf" $> F.FloatValue (F.Float32Value (1 / 0)), + "f64.inf" $> F.FloatValue (F.Float64Value (1 / 0)), + "-f32.inf" $> F.FloatValue (F.Float32Value (-1 / 0)), + "-f64.inf" $> F.FloatValue (F.Float64Value (-1 / 0)), + numeric + ] + where + numeric = do + x <- + signed (pure ()) $ choice [try float, fromInteger <$> decimal] + choice + [ floatV F.Float32Value x "f32", + floatV F.Float64Value x "f64", + floatV F.Float64Value x "" + ] + + floatV mk x suffix = + suffix $> F.FloatValue (mk (realToFrac (x :: Double))) + +-- | Parse a primitive value. Does *not* consume any trailing +-- whitespace, nor does it permit any internal whitespace. +parsePrimValue :: Parser F.PrimValue +parsePrimValue = + choice + [ try parseIntConst, + parseFloatConst, + "true" $> F.BoolValue True, + "false" $> F.BoolValue False + ] + +lexeme :: Parser () -> Parser a -> Parser a +lexeme sep p = p <* sep + +inBrackets :: Parser () -> Parser a -> Parser a +inBrackets sep = between (lexeme sep "[") (lexeme sep "]") + +-- | Parse a type. Does *not* consume any trailing whitespace, nor +-- does it permit any internal whitespace. +parseType :: Parser ValueType +parseType = ValueType <$> many parseDim <*> parsePrimType + where + parseDim = fromInteger <$> ("[" *> parseInteger <* "]") + +parseEmpty :: Parser Value +parseEmpty = do + ValueType dims t <- parseType + unless (product dims == 0) $ fail "Expected at least one empty dimension" + pure $ case t of + F.Signed F.Int8 -> Int8Value (SVec.fromList dims) mempty + F.Signed F.Int16 -> Int16Value (SVec.fromList dims) mempty + F.Signed F.Int32 -> Int32Value (SVec.fromList dims) mempty + F.Signed F.Int64 -> Int64Value (SVec.fromList dims) mempty + F.Unsigned F.Int8 -> Word8Value (SVec.fromList dims) mempty + F.Unsigned F.Int16 -> Word16Value (SVec.fromList dims) mempty + F.Unsigned F.Int32 -> Word32Value (SVec.fromList dims) mempty + F.Unsigned F.Int64 -> Word64Value (SVec.fromList dims) mempty + F.FloatType F.Float32 -> Float32Value (SVec.fromList dims) mempty + F.FloatType F.Float64 -> Float64Value (SVec.fromList dims) mempty + F.Bool -> BoolValue (SVec.fromList dims) mempty + +-- | Parse a value, given a post-lexeme parser for whitespace. +parseValue :: Parser () -> Parser Value +parseValue sep = + choice + [ putValue' $ lexeme sep parsePrimValue, + putValue' $ inBrackets sep (parseValue sep `sepBy` lexeme sep ","), + lexeme sep $ "empty(" *> parseEmpty <* ")" + ] + where + putValue' :: PutValue v => Parser v -> Parser Value + putValue' p = do + o <- getOffset + x <- p + case putValue x of + Nothing -> + parseError . FancyError o . S.singleton $ + ErrorFail "array is irregular or has elements of multiple types." + Just v -> + pure v diff --git a/src/Futhark/Transform/Substitute.hs b/src/Futhark/Transform/Substitute.hs --- a/src/Futhark/Transform/Substitute.hs +++ b/src/Futhark/Transform/Substitute.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} -- | @@ -64,7 +63,7 @@ substituteNames substs = fmap $ substituteNames substs instance Substitute Bool where - substituteNames = flip const + substituteNames = const id instance Substitute VName where substituteNames substs k = M.findWithDefault k k substs diff --git a/src/Futhark/Util/Options.hs b/src/Futhark/Util/Options.hs --- a/src/Futhark/Util/Options.hs +++ b/src/Futhark/Util/Options.hs @@ -3,6 +3,7 @@ ( FunOptDescr, mainWithOptions, commonOptions, + module System.Console.GetOpt, ) where diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs --- a/src/Futhark/Util/Pretty.hs +++ b/src/Futhark/Util/Pretty.hs @@ -9,6 +9,7 @@ prettyDoc, prettyTuple, prettyText, + prettyTextOneLine, prettyOneLine, apply, oneLine, @@ -32,6 +33,10 @@ -- | Prettyprint a value to a 'Text', wrapped to 80 characters. prettyText :: Pretty a => a -> Text prettyText = LT.toStrict . PP.prettyLazyText 80 . ppr + +-- | Prettyprint a value to a 'Text' without any width restriction. +prettyTextOneLine :: Pretty a => a -> Text +prettyTextOneLine = LT.toStrict . PP.prettyLazyText 80 . oneLine . ppr -- | Prettyprint a value without any width restriction. prettyOneLine :: Pretty a => a -> String diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs --- a/src/Language/Futhark.hs +++ b/src/Language/Futhark.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - -- | Re-export the external Futhark modules for convenience. module Language.Futhark ( module Language.Futhark.Syntax, diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -1626,13 +1626,14 @@ fun2t $ \i xs -> do let (shape, xs') = fromArray xs return $ - if asInt i > 0 - then - let (bef, aft) = splitAt (asInt i) xs' - in toArray shape $ aft ++ bef - else - let (bef, aft) = splitFromEnd (- asInt i) xs' - in toArray shape $ aft ++ bef + let idx = if null xs' then 0 else rem (asInt i) (length xs') + in if idx > 0 + then + let (bef, aft) = splitAt idx xs' + in toArray shape $ aft ++ bef + else + let (bef, aft) = splitFromEnd (- idx) xs' + in toArray shape $ aft ++ bef def "flatten" = Just $ fun1 $ \xs -> do let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs diff --git a/src/Language/Futhark/Parser.hs b/src/Language/Futhark/Parser.hs --- a/src/Language/Futhark/Parser.hs +++ b/src/Language/Futhark/Parser.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - -- | Interface to the Futhark parser. module Language.Futhark.Parser ( parseFuthark, diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs --- a/src/Language/Futhark/Prop.hs +++ b/src/Language/Futhark/Prop.hs @@ -118,6 +118,7 @@ import Data.Maybe import Data.Ord import qualified Data.Set as S +import qualified Data.Text as T import qualified Futhark.IR.Primitive as Primitive import Futhark.Util (maxinum, nubOrd) import Futhark.Util.Pretty @@ -386,9 +387,11 @@ sortFields l = map snd $ sortOn fst $ zip (map (fieldish . fst) l') l' where l' = M.toList l - fieldish s = case reads $ nameToString s of - [(x, "")] -> Left (x :: Int) - _ -> Right s + onDigit Nothing _ = Nothing + onDigit (Just d) c + | isDigit c = Just $ d * 10 + ord c - ord '0' + | otherwise = Nothing + fieldish s = maybe (Right s) Left $ T.foldl' onDigit (Just 0) $ nameToText s -- | Sort the constructors of a sum type in some well-defined (but not -- otherwise significant) manner. diff --git a/src/Language/Futhark/Semantic.hs b/src/Language/Futhark/Semantic.hs --- a/src/Language/Futhark/Semantic.hs +++ b/src/Language/Futhark/Semantic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - -- | Definitions of various semantic objects (*not* the Futhark -- semantics themselves). module Language.Futhark.Semantic diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} -- | The type checker checks whether the program is type-consistent -- and adds type annotations and various other elaborations. The @@ -43,7 +42,7 @@ -- | Type check a program containing no type information, yielding -- either a type error or a program with complete type information. -- Accepts a mapping from file names (excluding extension) to --- previously type checker results. The 'FilePath' is used to resolve +-- previously type checked results. The 'ImportName' is used to resolve -- relative @import@s. checkProg :: Imports -> @@ -699,20 +698,15 @@ return (mempty, env, ValDec vb') checkDecs :: [DecBase NoInfo Name] -> TypeM (TySet, Env, [DecBase Info VName]) -checkDecs (LocalDec d loc : ds) = do - (d_abstypes, d_env, d') <- checkOneDec d - (ds_abstypes, ds_env, ds') <- localEnv d_env $ checkDecs ds - return - ( d_abstypes <> ds_abstypes, - ds_env, - LocalDec d' loc : ds' - ) checkDecs (d : ds) = do (d_abstypes, d_env, d') <- checkOneDec d (ds_abstypes, ds_env, ds') <- localEnv d_env $ checkDecs ds return ( d_abstypes <> ds_abstypes, - ds_env <> d_env, + case d' of + LocalDec {} -> ds_env + ImportDec {} -> ds_env + _ -> ds_env <> d_env, d' : ds' ) checkDecs [] = diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs --- a/src/Language/Futhark/TypeChecker/Match.hs +++ b/src/Language/Futhark/TypeChecker/Match.hs @@ -162,6 +162,8 @@ findUnmatched _ _ = [] {-# NOINLINE unmatched #-} + +-- | Find the unmatched cases. unmatched :: [Pattern] -> [Match] unmatched orig_ps = -- The algorithm may find duplicate example, which we filter away diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs --- a/src/Language/Futhark/TypeChecker/Modules.hs +++ b/src/Language/Futhark/TypeChecker/Modules.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TupleSections #-} -- | Implementation of the Futhark module system (at least most of it; diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -412,7 +412,7 @@ | reachable (qs ++ orig_qs) name outer_env = QualName (qs ++ orig_qs) name | otherwise = case rem_qs of q : rem_qs' -> prependAsNecessary (qs ++ [q]) rem_qs' (QualName orig_qs name) - [] -> QualName (qs ++ orig_qs) name + [] -> QualName orig_qs name reachable [] name env = name `M.member` envVtable env diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -36,7 +36,7 @@ import Futhark.Util (nubOrd) import Futhark.Util.Pretty hiding (bool, group, space) import Language.Futhark hiding (unscopeType) -import Language.Futhark.Semantic (includeToString) +import Language.Futhark.Semantic (includeToFilePath) import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Match import Language.Futhark.TypeChecker.Monad hiding (BoundV) @@ -621,7 +621,7 @@ checkIntrinsic space qn@(QualName _ name) loc | Just v <- M.lookup (space, name) intrinsicsNameMap = do me <- liftTypeM askImportName - unless ("/prelude" `isPrefixOf` includeToString me) $ + unless ("/prelude" `isPrefixOf` includeToFilePath me) $ warn loc "Using intrinsic functions directly can easily crash the compiler or result in wrong code generation." scope <- asks termScope return (scope, v) diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} -- | Type checker building blocks that do not involve unification. module Language.Futhark.TypeChecker.Types diff --git a/src/Language/Futhark/Warnings.hs b/src/Language/Futhark/Warnings.hs --- a/src/Language/Futhark/Warnings.hs +++ b/src/Language/Futhark/Warnings.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - -- | A very simple representation of collections of warnings. -- Warnings have a position (so they can be ordered), and their -- 'Show'-instance produces a human-readable string. diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -18,6 +18,7 @@ import qualified Futhark.CLI.Dataset as Dataset import qualified Futhark.CLI.Dev as Dev import qualified Futhark.CLI.Doc as Doc +import qualified Futhark.CLI.Literate as Literate import qualified Futhark.CLI.Misc as Misc import qualified Futhark.CLI.Multicore as Multicore import qualified Futhark.CLI.OpenCL as OpenCL @@ -63,7 +64,8 @@ ("check", (Check.main, "Type check a program.")), ("imports", (Misc.mainImports, "Print all non-builtin imported Futhark files.")), ("autotune", (Autotune.main, "Autotune threshold parameters.")), - ("query", (Query.main, "Query semantic information about program.")) + ("query", (Query.main, "Query semantic information about program.")), + ("literate", (Literate.main, "Process a literate Futhark program.")) ] msg :: String diff --git a/unittests/Futhark/BenchTests.hs b/unittests/Futhark/BenchTests.hs --- a/unittests/Futhark/BenchTests.hs +++ b/unittests/Futhark/BenchTests.hs @@ -2,6 +2,7 @@ module Futhark.BenchTests (tests) where +import qualified Data.Map as M import qualified Data.Text as T import Futhark.Bench import Test.Tasty @@ -19,10 +20,11 @@ <$> printable <*> oneof [ Left <$> arbText, - Right <$> ((,) <$> arbitrary <*> arbText) + Right <$> (Result <$> arbitrary <*> arbMap <*> arbText) ] where arbText = T.pack <$> printable + arbMap = M.fromList <$> listOf ((,) <$> arbText <*> arbitrary) -- XXX: we restrict this generator to single datasets to we don't have -- to worry about duplicates.