diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -8,15 +8,22 @@ ``futlib.h``. The API provided in the ``.h`` file is documented in the following. -Usaging the API revolves around creating a *configuration object*, -which can then be used to obtain a *context object*, which must be -passed whenever entry points are called. +Using the API requires creating a *configuration object*, which is +then used to obtain a *context object*, which is then used to perform +most other operations, such as calling Futhark functions. Most functions that can fail return an integer: 0 on success and a non-zero value on error. Others return a ``NULL`` pointer. Use :c:func:`futhark_context_get_error` to get a (possibly) more precise error message. +.. c:macro:: FUTHARK_BACKEND_foo + + A preprocessor macro identifying that the backend *foo* was used to + generate the code; e.g. ``c``, ``opencl``, or ``cuda``. This can + be used for conditional compilation of code that only works with + specific backends. + Configuration ------------- @@ -26,7 +33,7 @@ freed before any context objects for which it is used. The same configuration may be used for multiple concurrent contexts. -.. c:type:: struct futhark_context_config +.. c:struct:: futhark_context_config An opaque struct representing a Futhark configuration. @@ -62,7 +69,7 @@ Context ------- -.. c:type:: struct futhark_context +.. c:struct:: futhark_context An opaque struct representing a Futhark context. @@ -82,8 +89,9 @@ .. c:function:: int futhark_context_sync(struct futhark_context *ctx) - Block until all outstanding operations have finished executing. - Many API functions are asynchronous on their own. + Block until all outstanding operations, including copies, have + finished executing. Many API functions are asynchronous on their + own. .. c:function:: void futhark_context_pause_profiling(struct futhark_context *ctx) @@ -143,7 +151,7 @@ unchanged, you should still free both the input and the output - this will not result in a double free. -.. c:type:: struct futhark_i32_1d +.. c:struct:: futhark_i32_1d An opaque struct representing a Futhark value of type ``[]i32``. @@ -171,8 +179,9 @@ .. c:function:: int futhark_values_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr, int32_t *data) - Copy data from the value into ``data``, which must be of sufficient - size. Multi-dimensional arrays are written in row-major form. + Asynchronously copy data from the value into ``data``, which must + be of sufficient size. Multi-dimensional arrays are written in + row-major form. .. c:function:: const int64_t *futhark_shape_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr) @@ -183,10 +192,10 @@ Entry points ------------ -Entry points are mapped 1:1 to C functions. Return value are handled -with "out"-parameters. +Entry points are mapped 1:1 to C functions. Return values are handled +with *out*-parameters. -For example, the following entry point:: +For example, this Futhark entry point:: entry sum = i32.sum @@ -216,7 +225,7 @@ Exotic ~~~~~~ -The following functions are not going to interesting to most users. +The following functions are not interesting to most users. .. c:function:: void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size) @@ -231,6 +240,16 @@ Set the default tile size used when executing kernels that have been block tiled. +.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) + + During :c:func:`futhark_context_new`, dump the OpenCL or CUDA + program source to the given file. + +.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) + + During :c:func:`futhark_context_new`, read OpenCL or CUDA program + source from the given file instead of using the embedded program. + OpenCL ------ @@ -270,16 +289,6 @@ Add a build option to the OpenCL kernel compiler. See the OpenCL specification for `clBuildProgram` for available options. -.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) - - During :c:func:`futhark_context_new`, dump the OpenCL program - source to the given file. - -.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) - - During :c:func:`futhark_context_new`, read OpenCL program source - from the given file instead of using the embedded program. - .. c:function:: void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char *path) During :c:func:`futhark_context_new`, dump the compiled OpenCL @@ -306,16 +315,6 @@ Add a build option to the NVRTC compiler. See the CUDA documentation for ``nvrtcCompileProgram`` for available options. - -.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) - - During :c:func:`futhark_context_new`, dump the CUDA program - source to the given file. - -.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) - - During :c:func:`futhark_context_new`, read CUDA program source - from the given file instead of using the embedded program. .. c:function:: void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char *path) diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -108,7 +108,7 @@ tokens = { 'root': [ - (r'(if|then|else|let|loop|in|val|for|do|with|local|open|include|import|type|entry|module|while|unsafe|module)\b', token.Keyword), + (r'(if|then|else|let|loop|in|val|for|do|with|local|open|include|import|type|entry|module|while|module)\b', token.Keyword), (r"[a-zA-Z_][a-zA-Z0-9_']*", token.Name), (r"-- .*", token.Comment), (r'.', token.Text) @@ -266,8 +266,6 @@ ('man/futhark-cuda', 'futhark-cuda', 'compile Futhark to CUDA', [], 1), ('man/futhark-python', 'futhark-python', 'compile Futhark to sequential Python', [], 1), ('man/futhark-pyopencl', 'futhark-pyopencl', 'compile Futhark to Python and OpenCL', [], 1), - ('man/futhark-csharp', 'futhark-csharp', 'compile Futhark to sequential C#', [], 1), - ('man/futhark-csopencl', 'futhark-csopencl', 'compile Futhark to C# and OpenCL', [], 1), ('man/futhark-run', 'futhark-run', 'interpret Futhark program', [], 1), ('man/futhark-repl', 'futhark-repl', 'interactive Futhark read-eval-print-loop', [], 1), ('man/futhark-test', 'futhark-test', 'test Futhark programs', [], 1), diff --git a/docs/hacking.rst b/docs/hacking.rst --- a/docs/hacking.rst +++ b/docs/hacking.rst @@ -93,3 +93,25 @@ allows you to tailor your own compilation pipeline using command line options. It is also useful for seeing what the AST looks like after specific passes. + +When you are about to have a bad day +------------------------------------ + +When using the ``cuda`` backend, you can use the ``--dump-ptx`` +runtime option to dump PTX, a kind of high-level assembly for NVIDIA +GPUs, corresponding to the GPU kernels. This can be used to +investigate why the generated code isn't running as fast as you expect +(not fun), or even whether NVIDIAs compiler is miscompiling something +(extremely not fun). With the OpenCL backend, +``--dump-opencl-binary`` does the same thing. + +On AMD platforms, ``--dump-opencl-binary`` tends to produce an actual +binary of some kind, and it is pretty tricky to obtain a debugger for +it (they are available and open source, but the documentation and +installation instructions are terrible). Instead, AMDs OpenCL kernel +compiler accepts a ``-save-temps=foo`` build option, which will make +it write certain intermediate files, prefixed with ``foo``. In +particular, it will write an ``.s`` file that contains what appears to +be HSA assembly (at least when using ROCm). If you find yourself +having to do do this, then you are definitely going to have a bad day, +and probably evening and night as well. diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -45,8 +45,6 @@ man/futhark-autotune.rst man/futhark-bench.rst man/futhark-c.rst - man/futhark-csharp.rst - man/futhark-csopencl.rst man/futhark-cuda.rst man/futhark-dataset.rst man/futhark-doc.rst diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -115,7 +115,7 @@ System`_). .. productionlist:: - tuple_type: "(" ")" | "(" `type` ("[" "," `type` "]")* ")" + tuple_type: "(" ")" | "(" `type` ("," `type`)+ ")" A tuple value or type is written as a sequence of comma-separated values or types enclosed in parentheses. For example, ``(0, 1)`` is a @@ -212,6 +212,7 @@ : | "open" `mod_exp` : | "import" `stringlit` : | "local" `dec` + : | "#[" attr "]" dec The ``open`` declaration brings names defined in another module into scope (see also `Module System`_). For the meaning of ``import``, see @@ -1172,8 +1173,9 @@ of an array *before* the ``f x`` application is encountered. The notion of "before" is subtle, as there is no evaluation ordering of a Futhark expression, *except* that a ``let``-binding is always -evaluated before its body, and the argument to a function is always -evaluated before the function. +evaluated before its body, the argument to a function is always +evaluated before the function itself, and the left operand to an +operator is evaluated before the right. The causality restriction only occurs when a function has size parameters whose first use is *not* as a concrete array size. For @@ -1538,6 +1540,7 @@ : | "type" ["^"] `id` `type_param`* : | "module" `id` ":" `mod_type_exp` : | "include" `mod_type_exp` + : | "#[" attr "]" spec spec_type: `type` | `type` "->" `spec_type` Module types classify modules, with the only (unimportant) difference @@ -1582,66 +1585,110 @@ .. productionlist:: attr: `id` + : | `id` "(" [`attr` ("," `attr`)*] ")" -An expression can be prefixed with an attribute, written as -``#[attr]``. This may affect how it is treated by the compiler or -other tools. In no case will attributes affect or change the -*semantics* of a program, but it may affect how well it compiles (or -in some cases, whether it compiles at all). Unknown attributes are -silently ignored. Most have no effect in the interpreter. +An expression, declaration, or module type spec can be prefixed with +an attribute, written as ``#[attr]``. This may affect how it is +treated by the compiler or other tools. In no case will attributes +affect or change the *semantics* of a program, but it may affect how +well it compiles and runs (or in some cases, whether it compiles or +runs at all). Unknown attributes are silently ignored. Most have no +effect in the interpreter. An attribute can be either an *atom*, +written as just an identifier, or *compound*, consisting of an +identifier and a comma-separated sequence of attributes. The latter +is used for grouping and encoding of more complex information. -Many attributes affect second-order array combinators (*SOACS*). -These must be applied to a fully saturated function application or -they will have no effect. If two SOACs with contradictory attributes -are combined through fusion, it is unspecified which attributes take -precedence. +Expression attributes +~~~~~~~~~~~~~~~~~~~~~ +Many expression attributes affect second-order array combinators +(*SOACS*). These must be applied to a fully saturated function +application or they will have no effect. If two SOACs with +contradictory attributes are combined through fusion, it is +unspecified which attributes take precedence. + The following expression attributes are supported. -``incremental_flattening_no_outer`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +``incremental_flattening(no_outer)`` +.................................... When using incremental flattening, do not generate the "only outer parallelism" version for the attributed SOACs. -``incremental_flattening_no_intra`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +``incremental_flattening(no_intra)`` +.................................... When using incremental flattening, do not generate the "intra-group parallelism" version for the attributed SOACs. -``incremental_flattening_only_inner`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +``incremental_flattening(only_intra)`` +...................................... +When using incremental flattening, *only* generate the "intra-group +parallelism" version of the attributed SOACs. **Beware**: the +resulting program will fail to run if the inner parallelism does not +fit on the device. + +``incremental_flattening(only_inner)`` +...................................... + When using incremental flattening, do not generate multiple versions for this SOAC, but do exploit inner parallelism (which may give rise to multiple versions at deeper levels). ``noinline`` -~~~~~~~~~~~~ +............ Do not inline the attributed function application. If used within a parallel construct (e.g. ``map``), this will likely prevent the GPU backends from generating working code. ``sequential`` -~~~~~~~~~~~~~~ +.............. *Fully* sequentialise the attributed SOAC. ``sequential_outer`` -~~~~~~~~~~~~~~~~~~~~ +.................... Turn the outer parallelism in the attributed SOAC sequential, but preserve any inner parallelism. ``sequential_inner`` -~~~~~~~~~~~~~~~~~~~~ +.................... Exploit only outer parallelism in the attributed SOAC. ``unsafe`` -~~~~~~~~~~ +.......... Do not perform any dynamic safety checks (such as bound checks) during execution of the attributed expression. + +``warn(safety_checks)`` +....................... + +Make the compiler issue a warning if the attributed expression (or its +subexpressions) requires safety checks (such as bounds checking) at +run-time. This is used for performance-critical code where you want +to be told when the compiler is unable to statically verify the safety +of all operations. + +Declaration attributes +~~~~~~~~~~~~~~~~~~~~~~ + +The following declaration attributes are supported. + +``noinline`` +............ + +Do not inline any calls to this function. If the function is then +used within a parallel construct (e.g. ``map``), this will likely +prevent the GPU backends from generating working code. + +Spec attributes +~~~~~~~~~~~~~~~ + +No spec attributes are currently supported by the compiler itself, +although they are syntactically permitted and may be used by other +tools. diff --git a/docs/man/futhark-autotune.rst b/docs/man/futhark-autotune.rst --- a/docs/man/futhark-autotune.rst +++ b/docs/man/futhark-autotune.rst @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark autotune [options...] program +futhark autotune [options...] DESCRIPTION =========== diff --git a/docs/man/futhark-bench.rst b/docs/man/futhark-bench.rst --- a/docs/man/futhark-bench.rst +++ b/docs/man/futhark-bench.rst @@ -86,8 +86,8 @@ directly, but instead the indicated *program* is run with its first argument being the path to the compiled Futhark program. This is useful for compilation targets that cannot be executed directly (as - with :ref:`futhark-csharp(1)`), or when you wish to run the program - on a remote machine. + with :ref:`futhark-pyopencl(1)` on some platforms), or when you wish + to run the program on a remote machine. --runs=count 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 @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark c [options...] infile +futhark c [options...] DESCRIPTION =========== diff --git a/docs/man/futhark-csharp.rst b/docs/man/futhark-csharp.rst deleted file mode 100644 --- a/docs/man/futhark-csharp.rst +++ /dev/null @@ -1,68 +0,0 @@ -.. role:: ref(emphasis) - -.. _futhark-csharp(1): - -============== -futhark-csharp -============== - -SYNOPSIS -======== - -futhark csharp [options...] infile - -DESCRIPTION -=========== - -``futhark csharp`` translates a Futhark program to sequential C# code, -and either compiles that C# code with the Roslyn C# Compiler ``csc`` -to an executable binary program, or produces a ``.dll`` file that can -be linked with other code.. The standard Futhark optimisation -pipeline is used, and ``csc`` is invoked with ``-lib:$MONO_PATH``, -``-r:Mono.Options.dll``, and ``/unsafe``. - -The resulting program will read the arguments to the entry point -(``main`` by default) from standard input and print its return value -on standard output. The arguments are read and printed in Futhark -syntax. - -OPTIONS -======= - --h - Print help text to standard output and exit. - ---library - Generate a library instead of an executable. Appends ``.dll`` - to the name indicated by the ``-o`` option to determine output - file names. - --o outfile - Where to write the result. If the source program is named - 'foo.fut', this defaults to 'foo'. - ---safe - Ignore ``unsafe`` in program and perform safety checks unconditionally. - --v verbose - Enable debugging output. If compilation fails due to a compiler - error, the result of the last successful compiler step will be - printed to standard error. - --W - Do not print any warnings. - --V - Print version information on standard output and exit. - -REQUIREMENTS -============ -``futhark csharp`` uses the Mono implementation of the .NET framework. -To compile and execute the compiled binaries/libraries, you must have the ``MONO_PATH`` environment variable defined. ``MONO_PATH`` must be set to a directory containing the ``Mono.Options`` dll. - -Mono.Options is available on https://www.nuget.org/packages/Mono.Options/5.3.0.1 - -SEE ALSO -======== - -:ref:`futhark-csopencl(1)` diff --git a/docs/man/futhark-csopencl.rst b/docs/man/futhark-csopencl.rst deleted file mode 100644 --- a/docs/man/futhark-csopencl.rst +++ /dev/null @@ -1,72 +0,0 @@ -.. role:: ref(emphasis) - -.. _futhark-csopencl(1): - -================ -futhark-csopencl -================ - -SYNOPSIS -======== - -futhark csopencl [options...] infile - -DESCRIPTION -=========== - - -``futhark csopencl`` translates a Futhark program to C# code invoking -OpenCL kernels, and either compiles that C# code with the Roslyn C# Compiler ``csc`` -to an executable binary program, or produces a ``.dll`` file that can be linked with -other code.. The standard Futhark optimisation pipeline is used, and -``csc`` is invoked with ``-lib:$MONO_PATH``, ``-r:Cloo.clSharp.dll``, -``-r:Mono.Options.dll``, and ``/unsafe``. - -The resulting program will otherwise behave exactly as -one compiled with ``futhark csharp``. - -OPTIONS -======= - --h - Print help text to standard output and exit. - ---library - Generate a library instead of an executable. Appends ``.dll`` - to the name indicated by the ``-o`` option to determine output - file names. - --o outfile - Where to write the result. If the source program is named - ``foo.fut``, this defaults to ``foo``. - ---safe - Ignore ``unsafe`` in program and perform safety checks unconditionally. - --v verbose - Enable debugging output. If compilation fails due to a compiler - error, the result of the last successful compiler step will be - printed to standard error. - --V - Print version information on standard output and exit. - --W - Do not print any warnings. - ---Werror - Treat warnings as errors. - -REQUIREMENTS -============ -``futhark csopencl`` uses the Mono implementation of the .NET framework. -To compile and execute the compiled binaries/libraries, you must have the ``MONO_PATH`` environment variable defined. ``MONO_PATH`` must be set to a directory containing the ``Mono.Options`` and ``Cloo.clSharp`` dll's. - -Mono.Options is available on https://www.nuget.org/packages/Mono.Options/5.3.0.1 - -Cloo.clSharp is available on https://www.nuget.org/packages/Cloo.clSharp/ - -SEE ALSO -======== - -:ref:`futhark-test(1)`, :ref:`futhark-csharp(1)` 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 @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark cuda [options...] infile +futhark cuda [options...] DESCRIPTION =========== 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 @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark opencl [options...] infile +futhark opencl [options...] DESCRIPTION =========== diff --git a/docs/man/futhark-repl.rst b/docs/man/futhark-repl.rst --- a/docs/man/futhark-repl.rst +++ b/docs/man/futhark-repl.rst @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark repl +futhark repl [program.fut] DESCRIPTION =========== diff --git a/docs/man/futhark-run.rst b/docs/man/futhark-run.rst --- a/docs/man/futhark-run.rst +++ b/docs/man/futhark-run.rst @@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark run [program] +futhark run DESCRIPTION =========== 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 @@ -172,8 +172,8 @@ directly, but instead the indicated *program* is run with its first argument being the path to the compiled Futhark program. This is useful for compilation targets that cannot be executed directly (as - with :ref:`futhark-csharp(1)`), or when you wish to run the program - on a remote machine. + with :ref:`futhark-pyopencl(1)` on some platforms), or when you wish + to run the program on a remote machine. --tuning=EXTENSION diff --git a/docs/requirements.txt b/docs/requirements.txt --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,1 +1,2 @@ pyyaml>=4.2b1 +sphinx==3.0.3 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.15.8 +version: 0.16.1 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -24,7 +24,7 @@ * "Futhark.Construct" explains how to write code that manipulates and creates AST fragments. . - <> + <> category: Language homepage: https://futhark-lang.org @@ -35,7 +35,6 @@ build-type: Simple extra-source-files: rts/c/*.h - rts/csharp/*.cs rts/futhark-doc/*.css rts/python/*.py prelude/*.fut @@ -54,7 +53,6 @@ library exposed-modules: Futhark.Actions - Futhark.Analysis.AlgSimplify Futhark.Analysis.Alias Futhark.Analysis.CallGraph Futhark.Analysis.DataDependencies @@ -65,9 +63,7 @@ Futhark.Analysis.PrimExp.Convert Futhark.Analysis.PrimExp.Generalize Futhark.Analysis.PrimExp.Simplify - Futhark.Analysis.Range Futhark.Analysis.Rephrase - Futhark.Analysis.ScalExp Futhark.Analysis.SymbolTable Futhark.Analysis.UsageTable Futhark.Bench @@ -76,8 +72,6 @@ Futhark.CLI.Autotune Futhark.CLI.Bench Futhark.CLI.C - Futhark.CLI.CSOpenCL - Futhark.CLI.CSharp Futhark.CLI.CUDA Futhark.CLI.Check Futhark.CLI.Datacmp @@ -97,14 +91,8 @@ Futhark.CodeGen.Backends.CCUDA.Boilerplate Futhark.CodeGen.Backends.COpenCL Futhark.CodeGen.Backends.COpenCL.Boilerplate - Futhark.CodeGen.Backends.CSOpenCL - Futhark.CodeGen.Backends.CSOpenCL.Boilerplate Futhark.CodeGen.Backends.GenericC Futhark.CodeGen.Backends.GenericC.Options - Futhark.CodeGen.Backends.GenericCSharp - Futhark.CodeGen.Backends.GenericCSharp.AST - Futhark.CodeGen.Backends.GenericCSharp.Definitions - Futhark.CodeGen.Backends.GenericCSharp.Options Futhark.CodeGen.Backends.GenericPython Futhark.CodeGen.Backends.GenericPython.AST Futhark.CodeGen.Backends.GenericPython.Definitions @@ -112,7 +100,6 @@ Futhark.CodeGen.Backends.PyOpenCL Futhark.CodeGen.Backends.PyOpenCL.Boilerplate Futhark.CodeGen.Backends.SequentialC - Futhark.CodeGen.Backends.SequentialCSharp Futhark.CodeGen.Backends.SequentialPython Futhark.CodeGen.Backends.SimpleRep Futhark.CodeGen.ImpCode @@ -158,13 +145,11 @@ Futhark.IR.Prop.Constants Futhark.IR.Prop.Names Futhark.IR.Prop.Patterns - Futhark.IR.Prop.Ranges Futhark.IR.Prop.Rearrange Futhark.IR.Prop.Reshape Futhark.IR.Prop.Scope Futhark.IR.Prop.TypeOf Futhark.IR.Prop.Types - Futhark.IR.Ranges Futhark.IR.RetType Futhark.IR.SOACS Futhark.IR.SOACS.SOAC @@ -220,7 +205,6 @@ Futhark.Pass.ExtractKernels.ToKernels Futhark.Pass.FirstOrderTransform Futhark.Pass.KernelBabysitting - Futhark.Pass.ResolveAssertions Futhark.Pass.Simplify Futhark.Passes Futhark.Pipeline @@ -333,9 +317,7 @@ type: exitcode-stdio-1.0 main-is: futhark_tests.hs other-modules: - Futhark.Analysis.ScalExpTests Futhark.BenchTests - Futhark.Optimise.AlgSimplifyTests Futhark.Pkg.SolveTests Futhark.IR.Prop.RearrangeTests Futhark.IR.Prop.ReshapeTests diff --git a/rts/c/cuda.h b/rts/c/cuda.h --- a/rts/c/cuda.h +++ b/rts/c/cuda.h @@ -67,7 +67,7 @@ cfg->load_ptx_from = NULL; cfg->default_block_size = 256; - cfg->default_grid_size = 256; + cfg->default_grid_size = 0; // Set properly later. cfg->default_tile_size = 32; cfg->default_threshold = 32*1024; @@ -82,6 +82,13 @@ cfg->size_classes = size_classes; } +// A record of something that happened. +struct profiling_record { + cudaEvent_t *events; // Points to two events. + int *runs; + int64_t *runtime; +}; + struct cuda_context { CUdevice dev; CUcontext cu_ctx; @@ -99,6 +106,10 @@ size_t max_bespoke; size_t lockstep_width; + + struct profiling_record *profiling_records; + int profiling_records_capacity; + int profiling_records_used; }; #define CU_DEV_ATTR(x) (CU_DEVICE_ATTRIBUTE_##x) @@ -352,6 +363,13 @@ ctx->cfg.default_tile_size = ctx->max_tile_size; } + if (!ctx->cfg.default_grid_size_changed) { + ctx->cfg.default_grid_size = + (device_query(ctx->dev, MULTIPROCESSOR_COUNT) * + device_query(ctx->dev, MAX_THREADS_PER_MULTIPROCESSOR)) + / ctx->cfg.default_block_size; + } + for (int i = 0; i < ctx->cfg.num_sizes; i++) { const char *size_class, *size_name; size_t *size_value, max_value, default_value; @@ -366,6 +384,12 @@ } else if (strstr(size_class, "num_groups") == size_class) { max_value = ctx->max_grid_size; default_value = ctx->cfg.default_grid_size; + // XXX: as a quick and dirty hack, use twice as many threads for + // histograms by default. We really should just be smarter + // about sizes somehow. + if (strstr(size_name, ".seghist_") != NULL) { + default_value *= 2; + } } else if (strstr(size_class, "tile_size") == size_class) { max_value = ctx->max_tile_size; default_value = ctx->cfg.default_tile_size; @@ -449,10 +473,62 @@ cuda_module_setup(ctx, src_fragments, extra_opts); } +// Count up the runtime all the profiling_records that occured during execution. +// Also clears the buffer of profiling_records. +static cudaError_t cuda_tally_profiling_records(struct cuda_context *ctx) { + cudaError_t err; + for (int i = 0; i < ctx->profiling_records_used; i++) { + struct profiling_record record = ctx->profiling_records[i]; + + float ms; + if ((err = cudaEventElapsedTime(&ms, record.events[0], record.events[1])) != CUDA_SUCCESS) { + return err; + } + + // CUDA provides milisecond resolution, but we want microseconds. + *record.runs += 1; + *record.runtime += ms*1000; + + if ((err = cudaEventDestroy(record.events[0])) != CUDA_SUCCESS) { + return err; + } + if ((err = cudaEventDestroy(record.events[1])) != CUDA_SUCCESS) { + return err; + } + + free(record.events); + } + + ctx->profiling_records_used = 0; + + return CUDA_SUCCESS; +} + +// Returns pointer to two events. +static cudaEvent_t* cuda_get_events(struct cuda_context *ctx, int *runs, int64_t *runtime) { + if (ctx->profiling_records_used == ctx->profiling_records_capacity) { + ctx->profiling_records_capacity *= 2; + ctx->profiling_records = + realloc(ctx->profiling_records, + ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + } + cudaEvent_t *events = calloc(2, sizeof(cudaEvent_t)); + cudaEventCreate(&events[0]); + cudaEventCreate(&events[1]); + ctx->profiling_records[ctx->profiling_records_used].events = events; + ctx->profiling_records[ctx->profiling_records_used].runs = runs; + ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; + ctx->profiling_records_used++; + return events; +} + static CUresult cuda_free_all(struct cuda_context *ctx); static void cuda_cleanup(struct cuda_context *ctx) { CUDA_SUCCEED(cuda_free_all(ctx)); + (void)cuda_tally_profiling_records(ctx); + free(ctx->profiling_records); CUDA_SUCCEED(cuModuleUnload(ctx->module)); CUDA_SUCCEED(cuCtxDestroy(ctx->cu_ctx)); } @@ -464,7 +540,7 @@ } size_t size; - if (free_list_find(&ctx->free_list, tag, &size, mem_out) == 0) { + if (free_list_find(&ctx->free_list, min_size, &size, mem_out) == 0) { if (size >= min_size) { return CUDA_SUCCESS; } else { @@ -498,7 +574,7 @@ CUdeviceptr existing_mem; // If there is already a block with this tag, then remove it. - if (free_list_find(&ctx->free_list, tag, &size, &existing_mem) == 0) { + if (free_list_find(&ctx->free_list, -1, &size, &existing_mem) == 0) { CUresult res = cuMemFree(existing_mem); if (res != CUDA_SUCCESS) { return res; diff --git a/rts/c/free_list.h b/rts/c/free_list.h --- a/rts/c/free_list.h +++ b/rts/c/free_list.h @@ -1,8 +1,8 @@ // Start of free_list.h. -/* An entry in the free list. May be invalid, to avoid having to - deallocate entries as soon as they are removed. There is also a - tag, to help with memory reuse. */ +// An entry in the free list. May be invalid, to avoid having to +// deallocate entries as soon as they are removed. There is also a +// tag, to help with memory reuse. struct free_list_entry { size_t size; fl_mem_t mem; @@ -25,7 +25,7 @@ } } -/* Remove invalid entries from the free list. */ +// Remove invalid entries from the free list. static void free_list_pack(struct free_list *l) { int p = 0; for (int i = 0; i < l->capacity; i++) { @@ -82,25 +82,36 @@ l->used++; } -/* Find and remove a memory block of at least the desired size and - tag. Returns 0 on success. */ -static int free_list_find(struct free_list *l, const char *tag, size_t *size_out, fl_mem_t *mem_out) { +// Find and remove a memory block of the indicated tag, or if that +// does not exist, another memory block with exactly the desired size. +// Returns 0 on success. +static int free_list_find(struct free_list *l, size_t size, + size_t *size_out, fl_mem_t *mem_out) { + int size_match = -1; int i; for (i = 0; i < l->capacity; i++) { - if (l->entries[i].valid && l->entries[i].tag == tag) { - l->entries[i].valid = 0; - *size_out = l->entries[i].size; - *mem_out = l->entries[i].mem; - l->used--; - return 0; + if (l->entries[i].valid && + size <= l->entries[i].size && + (size_match < 0 || l->entries[i].size < l->entries[size_match].size)) { + // If this entry is valid, has sufficient size, and is smaller than the + // best entry found so far, use this entry. + size_match = i; } } - return 1; + if (size_match >= 0) { + l->entries[size_match].valid = 0; + *size_out = l->entries[size_match].size; + *mem_out = l->entries[size_match].mem; + l->used--; + return 0; + } else { + return 1; + } } -/* Remove the first block in the free list. Returns 0 if a block was - removed, and nonzero if the free list was already empty. */ +// Remove the first block in the free list. Returns 0 if a block was +// removed, and nonzero if the free list was already empty. static int free_list_first(struct free_list *l, fl_mem_t *mem_out) { for (int i = 0; i < l->capacity; i++) { if (l->entries[i].valid) { diff --git a/rts/c/lock.h b/rts/c/lock.h --- a/rts/c/lock.h +++ b/rts/c/lock.h @@ -1,20 +1,20 @@ // Start of lock.h. -/* A very simple cross-platform implementation of locks. Uses - pthreads on Unix and some Windows thing there. Futhark's - host-level code is not multithreaded, but user code may be, so we - need some mechanism for ensuring atomic access to API functions. - This is that mechanism. It is not exposed to user code at all, so - we do not have to worry about name collisions. */ +// A very simple cross-platform implementation of locks. Uses +// pthreads on Unix and some Windows thing there. Futhark's +// host-level code is not multithreaded, but user code may be, so we +// need some mechanism for ensuring atomic access to API functions. +// This is that mechanism. It is not exposed to user code at all, so +// we do not have to worry about name collisions. #ifdef _WIN32 typedef HANDLE lock_t; static lock_t create_lock(lock_t *lock) { - *lock = CreateMutex(NULL, /* Default security attributes. */ - FALSE, /* Initially unlocked. */ - NULL); /* Unnamed. */ + *lock = CreateMutex(NULL, // Default security attributes. + FALSE, // Initially unlocked. + NULL); // Unnamed. } static void lock_lock(lock_t *lock) { @@ -30,7 +30,7 @@ } #else -/* Assuming POSIX */ +// Assuming POSIX #include @@ -52,7 +52,7 @@ } static void free_lock(lock_t *lock) { - /* Nothing to do for pthreads. */ + // Nothing to do for pthreads. (void)lock; } diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -123,10 +123,10 @@ char *device_name; }; -/* This function must be defined by the user. It is invoked by - setup_opencl() after the platform and device has been found, but - before the program is loaded. Its intended use is to tune - constants based on the selected platform and device. */ +// This function must be defined by the user. It is invoked by +// setup_opencl() after the platform and device has been found, but +// before the program is loaded. Its intended use is to tune +// constants based on the selected platform and device. static void post_opencl_setup(struct opencl_context*, struct opencl_device_option*); static char *strclone(const char *str) { @@ -465,8 +465,8 @@ return build_status; } -/* Fields in a bitmask indicating which types we must be sure are - available. */ +// Fields in a bitmask indicating which types we must be sure are +// available. enum opencl_required_type { OPENCL_F64 = 1 }; // We take as input several strings representing the program, because @@ -526,6 +526,16 @@ OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_LOCAL_MEM_SIZE, sizeof(size_t), &max_local_memory, NULL)); + // Futhark reserves 4 bytes for bookkeeping information. + max_local_memory -= 4; + + // NVIDIA reserves some more bytes for who-knows-what. The number + // of bytes here has been experimentally determined, but the + // overhead seems to vary a bit depending on what the kernel does. + if (strstr(device_option.platform_name, "NVIDIA CUDA") != NULL) { + max_local_memory -= 12; + } + // Make sure this function is defined. post_opencl_setup(ctx, &device_option); @@ -563,6 +573,12 @@ } else if (strstr(size_class, "num_groups") == size_class) { max_value = max_group_size; // Futhark assumes this constraint. default_value = ctx->cfg.default_num_groups; + // XXX: as a quick and dirty hack, use twice as many threads for + // histograms by default. We really should just be smarter + // about sizes somehow. + if (strstr(size_name, ".seghist_") != NULL) { + default_value *= 2; + } } else if (strstr(size_class, "tile_size") == size_class) { max_value = sqrt(max_group_size); default_value = ctx->cfg.default_tile_size; @@ -682,6 +698,7 @@ } if (ctx->cfg.debugging) { + fprintf(stderr, "OpenCL compiler options: %s\n", compile_opts); fprintf(stderr, "Building OpenCL program...\n"); } OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); @@ -833,7 +850,7 @@ size_t size; - if (free_list_find(&ctx->free_list, tag, &size, mem_out) == 0) { + if (free_list_find(&ctx->free_list, min_size, &size, mem_out) == 0) { // Successfully found a free block. Is it big enough? // // FIXME: we might also want to check whether the block is *too @@ -848,8 +865,16 @@ // expose OpenCL pointer values directly to the application, but // instead rely on a level of indirection. if (size >= min_size) { + if (ctx->cfg.debugging) { + fprintf(stderr, "No need to allocate: Found a block in the free list.\n"); + } + return CL_SUCCESS; } else { + if (ctx->cfg.debugging) { + fprintf(stderr, "Found a free block, but it was too small.\n"); + } + // Not just right - free it. int error = clReleaseMemObject(*mem_out); if (error != CL_SUCCESS) { @@ -866,6 +891,10 @@ // have to check after every deallocation. This might be pretty // expensive. Let's hope that this case is hit rarely. + if (ctx->cfg.debugging) { + fprintf(stderr, "Actually allocating the desired block.\n"); + } + int error = opencl_alloc_actual(ctx, min_size, mem_out); while (error == CL_MEM_OBJECT_ALLOCATION_FAILURE) { @@ -892,7 +921,7 @@ cl_mem existing_mem; // If there is already a block with this tag, then remove it. - if (free_list_find(&ctx->free_list, tag, &size, &existing_mem) == 0) { + if (free_list_find(&ctx->free_list, -1, &size, &existing_mem) == 0) { int error = clReleaseMemObject(existing_mem); if (error != CL_SUCCESS) { return error; diff --git a/rts/c/timing.h b/rts/c/timing.h --- a/rts/c/timing.h +++ b/rts/c/timing.h @@ -15,7 +15,7 @@ } #else -/* Assuming POSIX */ +// Assuming POSIX #include #include diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -20,20 +20,20 @@ va_start(vl, s); size_t needed = 1 + (size_t)vsnprintf(NULL, 0, s, vl); char *buffer = (char*) malloc(needed); - va_start(vl, s); /* Must re-init. */ + va_start(vl, s); // Must re-init. vsnprintf(buffer, needed, s, vl); return buffer; } // Read a file into a NUL-terminated string; returns NULL on error. -static char* slurp_file(const char *filename, size_t *size) { - char *s; +static void* slurp_file(const char *filename, size_t *size) { + unsigned char *s; FILE *f = fopen(filename, "rb"); // To avoid Windows messing with linebreaks. if (f == NULL) return NULL; fseek(f, 0, SEEK_END); size_t src_size = ftell(f); fseek(f, 0, SEEK_SET); - s = (char*) malloc(src_size + 1); + s = (unsigned char*) malloc(src_size + 1); if (fread(s, 1, src_size, f) != src_size) { free(s); s = NULL; @@ -51,7 +51,7 @@ // Dump 'n' bytes from 'buf' into the file at the designated location. // Returns 0 on success. -static int dump_file(const char *file, const char *buf, size_t n) { +static int dump_file(const char *file, const void *buf, size_t n) { FILE *f = fopen(file, "w"); if (f == NULL) { @@ -92,7 +92,7 @@ b->str = realloc(b->str, b->capacity); } - va_start(vl, s); /* Must re-init. */ + va_start(vl, s); // Must re-init. vsnprintf(b->str+b->used, b->capacity-b->used, s, vl); b->used += needed; } diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -277,11 +277,11 @@ } static int read_str_i8(char *buf, void* dest) { - /* Some platforms (WINDOWS) does not support scanf %hhd or its - cousin, %SCNi8. Read into int first to avoid corrupting - memory. - - https://gcc.gnu.org/bugzilla/show_bug.cgi?id=63417 */ + // Some platforms (WINDOWS) does not support scanf %hhd or its + // cousin, %SCNi8. Read into int first to avoid corrupting + // memory. + // + // https://gcc.gnu.org/bugzilla/show_bug.cgi?id=63417 remove_underscores(buf); int j, x; if (sscanf(buf, "%i%n", &x, &j) == 1) { @@ -293,11 +293,11 @@ } static int read_str_u8(char *buf, void* dest) { - /* Some platforms (WINDOWS) does not support scanf %hhd or its - cousin, %SCNu8. Read into int first to avoid corrupting - memory. - - https://gcc.gnu.org/bugzilla/show_bug.cgi?id=63417 */ + // Some platforms (WINDOWS) does not support scanf %hhd or its + // cousin, %SCNu8. Read into int first to avoid corrupting + // memory. + // + // https://gcc.gnu.org/bugzilla/show_bug.cgi?id=63417 remove_underscores(buf); int j, x; if (sscanf(buf, "%i%n", &x, &j) == 1) { diff --git a/rts/csharp/exceptions.cs b/rts/csharp/exceptions.cs deleted file mode 100644 --- a/rts/csharp/exceptions.cs +++ /dev/null @@ -1,6 +0,0 @@ -private class ValueError : Exception -{ - public ValueError(){} - public ValueError(string message):base(message){} - public ValueError(string message, Exception inner):base(message, inner){} -} diff --git a/rts/csharp/memory.cs b/rts/csharp/memory.cs deleted file mode 100644 --- a/rts/csharp/memory.cs +++ /dev/null @@ -1,457 +0,0 @@ -public struct FlatArray -{ - public long[] shape; - public T[] array; - - public FlatArray(T[] data_array, long[] shape_array) - { - shape = shape_array; - array = data_array; - } - - public FlatArray(T[] data_array) - { - shape = new long[] {data_array.Length}; - array = data_array; - } - - private long getIdx(int[] idxs) - { - long idx = 0; - for (int i = 0; i", desc); - } -} - -private byte[] allocateMem(sbyte size) -{ - return new byte[size]; -} - -private byte[] allocateMem(short size) -{ - return new byte[size]; -} - -private byte[] allocateMem(int size) -{ - return new byte[size]; -} - -private byte[] allocateMem(long size) -{ - return new byte[size]; -} - -private byte[] allocateMem(byte size) -{ - return new byte[size]; -} - -private byte[] allocateMem(ushort size) -{ - return new byte[size]; -} - -private byte[] allocateMem(uint size) -{ - return new byte[size]; -} - -private byte[] allocateMem(ulong size) -{ - return new byte[size]; -} - -private Tuple createTuple_byte(byte[] bytes, long[] shape) -{ - var byteArray = new byte[bytes.Length / sizeof(byte)]; - Buffer.BlockCopy(bytes, 0, byteArray, 0, bytes.Length); - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_ushort(byte[] bytes, long[] shape) -{ - var ushortArray = new ushort[bytes.Length / sizeof(ushort)]; - Buffer.BlockCopy(bytes, 0, ushortArray, 0, bytes.Length); - return Tuple.Create(ushortArray, shape); -} - -private Tuple createTuple_uint(byte[] bytes, long[] shape) -{ - var uintArray = new uint[bytes.Length / sizeof(uint)]; - Buffer.BlockCopy(bytes, 0, uintArray, 0, bytes.Length); - return Tuple.Create(uintArray, shape); -} - -private Tuple createTuple_ulong(byte[] bytes, long[] shape) -{ - var ulongArray = new ulong[bytes.Length / sizeof(ulong)]; - Buffer.BlockCopy(bytes, 0, ulongArray, 0, bytes.Length); - return Tuple.Create(ulongArray, shape); -} - - -private Tuple createTuple_sbyte(byte[] bytes, long[] shape) -{ - var sbyteArray = new sbyte[1]; - if (bytes.Length > 0) - { - sbyteArray = new sbyte[bytes.Length / sizeof(sbyte)]; - } - Buffer.BlockCopy(bytes, 0, sbyteArray, 0, bytes.Length); - return Tuple.Create(sbyteArray, shape); -} - - -private Tuple createTuple_short(byte[] bytes, long[] shape) -{ - var shortArray = new short[1]; - if (bytes.Length > 0) - { - shortArray = new short[bytes.Length / sizeof(short)]; - } - Buffer.BlockCopy(bytes, 0, shortArray, 0, bytes.Length); - return Tuple.Create(shortArray, shape); -} - -private Tuple createTuple_int(byte[] bytes, long[] shape) -{ - var intArray = new int[1]; - if (bytes.Length > 0) - { - intArray = new int[bytes.Length / sizeof(int)]; - } - Buffer.BlockCopy(bytes, 0, intArray, 0, bytes.Length); - return Tuple.Create(intArray, shape); -} - -private Tuple createTuple_long(byte[] bytes, long[] shape) -{ - var longArray = new long[1]; - if (bytes.Length > 0) - { - longArray = new long[bytes.Length / sizeof(long)]; - } - Buffer.BlockCopy(bytes, 0, longArray, 0, bytes.Length); - return Tuple.Create(longArray, shape); -} - -private Tuple createTuple_float(byte[] bytes, long[] shape) -{ - var floatArray = new float[1]; - if (bytes.Length > 0) - { - floatArray = new float[bytes.Length / sizeof(float)]; - } - Buffer.BlockCopy(bytes, 0, floatArray, 0, bytes.Length); - return Tuple.Create(floatArray, shape); -} - - -private Tuple createTuple_double(byte[] bytes, long[] shape) -{ - var doubleArray = new double[1]; - if (bytes.Length > 0) - { - doubleArray = new double[bytes.Length / sizeof(double)]; - } - Buffer.BlockCopy(bytes, 0, doubleArray, 0, bytes.Length); - return Tuple.Create(doubleArray, shape); -} - -private Tuple createTuple_bool(byte[] bytes, long[] shape) -{ - var boolArray = new bool[1]; - if (bytes.Length > 0) - { - boolArray = new bool[bytes.Length / sizeof(bool)]; - } - Buffer.BlockCopy(bytes, 0, boolArray, 0, bytes.Length); - return Tuple.Create(boolArray, shape); -} - -private byte[] unwrapArray(Array src, int obj_size) -{ - var bytes = new byte[src.Length * obj_size]; - Buffer.BlockCopy(src, 0, bytes, 0, bytes.Length); - return bytes; -} - -private byte indexArray_byte(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(byte*) dest_ptr; - } - } -} - -private ushort indexArray_ushort(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(ushort*) dest_ptr; - } - } -} - -private uint indexArray_uint(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(uint*) dest_ptr; - } - } -} - -private ulong indexArray_ulong(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(ulong*) dest_ptr; - } - } -} - -private sbyte indexArray_sbyte(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(sbyte*) dest_ptr; - } - } -} - -private short indexArray_short(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(short*) dest_ptr; - } - } -} - -private int indexArray_int(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(int*) dest_ptr; - } - } -} - -private long indexArray_long(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(long*) dest_ptr; - } - } -} - -private float indexArray_float(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(float*) dest_ptr; - } - } -} - -private double indexArray_double(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(double*) dest_ptr; - } - } -} - -private bool indexArray_bool(byte[] src, int offset) -{ - unsafe - { - fixed (void* dest_ptr = &src[offset]) - { - return *(bool*) dest_ptr; - } - } -} - -private void writeScalarArray(byte[] dest, int offset, sbyte value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(sbyte*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, byte value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(byte*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, short value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(short*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, ushort value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(ushort*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, int value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(int*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, uint value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(uint*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, long value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(long*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, ulong value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(ulong*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, float value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(float*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, double value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(double*) dest_ptr = value; - } - } -} -private void writeScalarArray(byte[] dest, int offset, bool value) -{ - unsafe - { - fixed (byte* dest_ptr = &dest[offset]) - { - *(bool*) dest_ptr = value; - } - } -} diff --git a/rts/csharp/memory_opencl.cs b/rts/csharp/memory_opencl.cs deleted file mode 100644 --- a/rts/csharp/memory_opencl.cs +++ /dev/null @@ -1,231 +0,0 @@ -private Tuple createTuple_byte(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new byte[1]; - if (nbytes > 0) - { - byteArray = new byte[nbytes / sizeof(byte)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_ushort(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new ushort[1]; - if (nbytes > 0) - { - byteArray = new ushort[nbytes / sizeof(ushort)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_uint(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new uint[1]; - if (nbytes > 0) - { - byteArray = new uint[nbytes / sizeof(uint)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_ulong(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new ulong[1]; - if (nbytes > 0) - { - byteArray = new ulong[nbytes / sizeof(ulong)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_sbyte(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new sbyte[1]; - if (nbytes > 0) - { - byteArray = new sbyte[nbytes / sizeof(sbyte)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_short(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new short[1]; - if (nbytes > 0) - { - byteArray = new short[nbytes / sizeof(short)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_int(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new int[1]; - if (nbytes > 0) - { - byteArray = new int[nbytes / sizeof(int)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_long(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new long[1]; - if (nbytes > 0) - { - byteArray = new long[nbytes / sizeof(long)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_float(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new float[1]; - if (nbytes > 0) - { - byteArray = new float[nbytes / sizeof(float)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_double(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new double[1]; - if (nbytes > 0) - { - byteArray = new double[nbytes / sizeof(double)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - -private Tuple createTuple_bool(CLMemoryHandle mem, CLCommandQueueHandle queue, - int nbytes, long[] shape) -{ - var byteArray = new bool[1]; - if (nbytes > 0) - { - byteArray = new bool[nbytes / sizeof(bool)]; - } - unsafe - { - fixed(void* ptr = &byteArray[0]) - { - CL10.EnqueueReadBuffer(queue, mem, true, - new IntPtr(0), new IntPtr(nbytes), new IntPtr(ptr), - 0, null, null - ); - } - } - return Tuple.Create(byteArray, shape); -} - diff --git a/rts/csharp/opencl.cs b/rts/csharp/opencl.cs deleted file mode 100644 --- a/rts/csharp/opencl.cs +++ /dev/null @@ -1,964 +0,0 @@ -// Stub code for OpenCL setup. - -private void OPENCL_SUCCEED(int return_code, - [CallerFilePath] string filePath = "", - [CallerLineNumber] int lineNumber = 0) -{ - OpenCLSucceed(return_code, "", filePath, lineNumber); -} - -private void OPENCL_SUCCEED(ComputeErrorCode return_code, - [CallerFilePath] string filePath = "", - [CallerLineNumber] int lineNumber = 0) -{ - OpenCLSucceed((int) return_code, "", filePath, lineNumber); -} - -private void OPENCL_SUCCEED(object return_code, - [CallerFilePath] string filePath = "", - [CallerLineNumber] int lineNumber = 0) -{ - OpenCLSucceed((int) return_code, "", filePath, lineNumber); -} - -public struct OpenCLConfig -{ - public bool Debugging; - public int PreferredDeviceNum; - public string PreferredPlatform; - public string PreferredDevice; - - public string DumpProgramTo; - public string LoadProgramFrom; - - public int DefaultGroupSize; - public int DefaultNumGroups; - public int DefaultTileSize; - public int DefaultThreshold; - - public int NumSizes; - public string[] SizeNames; - public string[] SizeVars; - public int[] SizeValues; - public string[] SizeClasses; -} - -private void MemblockUnrefDevice(ref FutharkContext - context, ref OpenCLMemblock block, string desc) -{ - if (!block.IsNull) - { - block.DecreaseRefs(); - if (context.DetailMemory) - { - Console.Error.WriteLine(String.Format( - "Unreferencing block {0} (allocated as {1}) in {2}: {3} references remaining.", - desc, block.Tag, "space 'device'", block.References)); - } - - if (block.References == 0) - { - context.CurrentMemUsageDevice -= block.Size; - OPENCL_SUCCEED(OpenCLFree(ref context, block.Mem, block.Tag)); - block.IsNull = true; - } - - if (context.DetailMemory) - { - Console.Error.WriteLine(String.Format( - "{0} bytes freed (now allocated: {1} bytes)", - block.Size, context.CurrentMemUsageDevice)); - } - } -} - -private void MemblockSetDevice(ref FutharkContext context, - ref OpenCLMemblock lhs, ref OpenCLMemblock rhs, string lhs_desc) -{ - MemblockUnrefDevice(ref context, ref lhs, lhs_desc); - rhs.IncreaseRefs(); - lhs = rhs; -} - -private OpenCLMemblock MemblockAllocDevice(ref FutharkContext context, OpenCLMemblock block, long size, string desc) -{ - if (size < 0) - { - panic(1, String.Format("Negative allocation of {0} bytes attempted for {1} in {2}", - size, desc)); - } - - MemblockUnrefDevice(ref context, ref block, desc); - OPENCL_SUCCEED(OpenCLAlloc(ref context, size, desc, ref block.Mem)); - - block.References = 1; - block.IsNull = false; - block.Size = size; - block.Tag = desc; - context.CurrentMemUsageDevice += size; - - if (context.DetailMemory) - { - Console.Error.Write(String.Format("Allocated {0} bytes for {1} in {2} (now allocated: {3} bytes)", - size, desc, "space 'device'", Ctx.CurrentMemUsageDevice)); - } - - if (context.CurrentMemUsageDevice > context.PeakMemUsageDevice) - { - context.PeakMemUsageDevice = context.CurrentMemUsageDevice; - if (context.DetailMemory) - { - Console.Error.Write(" (new peak).\n"); - } - } - else if (context.DetailMemory) - { - Console.Error.Write(".\n"); - } - - return block; -} - - -private bool FreeListFind(ref OpenCLFreeList free_list, string tag, ref long size_out, ref CLMemoryHandle mem_out) -{ - for (int i = 0; i < free_list.Capacity; i++) - { - if (free_list.Entries[i].Valid && free_list.Entries[i].Tag == tag) - { - free_list.Entries[i].Valid = false; - size_out = free_list.Entries[i].Size; - mem_out = free_list.Entries[i].Mem; - free_list.Used--; - return true; - } - } - - return false; -} - -private bool FreeListFirst(ref OpenCLFreeList free_list, ref CLMemoryHandle mem_out) -{ - for (int i = 0; i < free_list.Capacity; i++) - { - if (free_list.Entries[i].Valid) - { - free_list.Entries[i].Valid = false; - mem_out = free_list.Entries[i].Mem; - free_list.Used--; - return true; - } - } - return false; -} - -private ComputeErrorCode OpenCLAllocActual(ref FutharkContext context, long min_size, ref CLMemoryHandle mem) -{ - ComputeErrorCode error; - mem = CL10.CreateBuffer(context.OpenCL.Context, ComputeMemoryFlags.ReadWrite - , new IntPtr(min_size), IntPtr.Zero, out error); - - if (error != ComputeErrorCode.Success) - { - return error; - } - - int x = 2; - unsafe - { - error = CL10.EnqueueWriteBuffer(Ctx.OpenCL.Queue, mem, true, IntPtr.Zero, new IntPtr(sizeof(int)), new IntPtr(&x), 0, null, null); - } - - return error; -} - -private ComputeErrorCode OpenCLAlloc(ref FutharkContext context, long min_size, string tag, ref CLMemoryHandle mem_out) -{ - if (min_size < 0) - { - panic(1, "Tried to allocate a negative amount of bytes."); - } - - min_size = (min_size < sizeof(int)) ? sizeof(int) : min_size; - - long size = 0; - - if (FreeListFind(ref context.FreeList, tag, ref size, ref mem_out)) - { - if (size >= min_size && size <= min_size * 2) - { - return ComputeErrorCode.Success; - } - else - { - ComputeErrorCode code1 = CL10.ReleaseMemObject(mem_out); - if (code1 != ComputeErrorCode.Success) - { - return code1; - } - } - } - - ComputeErrorCode error = OpenCLAllocActual(ref context, min_size, ref mem_out); - while (error == ComputeErrorCode.MemoryObjectAllocationFailure) - { - CLMemoryHandle mem = Ctx.EMPTY_MEM_HANDLE; - if (FreeListFirst(ref context.FreeList, ref mem)) - { - error = CL10.ReleaseMemObject(mem); - if (error != ComputeErrorCode.Success) - { - return error; - } - } - else - { - break; - } - - error = OpenCLAllocActual(ref context, min_size, ref mem_out); - } - return error; -} - - -private ComputeErrorCode OpenCLFree(ref FutharkContext context, CLMemoryHandle mem, string tag) -{ - long size = 0; - CLMemoryHandle existing_mem = Ctx.EMPTY_MEM_HANDLE; - ComputeErrorCode error = ComputeErrorCode.Success; - if (FreeListFind(ref context.FreeList, tag, ref size, ref existing_mem)) - { - error = CL10.ReleaseMemObject(existing_mem); - if (error != ComputeErrorCode.Success) - { - return error; - } - } - - if (existing_mem.Value == mem.Value) - { - return error; - } - - var trash_null = new IntPtr(0); - unsafe - { - error = CL10.GetMemObjectInfo(mem, ComputeMemoryInfo.Size, - new IntPtr(sizeof(long)), new IntPtr(&size), out trash_null); - } - - if (error == ComputeErrorCode.Success) - { - FreeListInsert(ref context, size, mem, tag); - } - return error; -} - -private void FreeListInsert(ref FutharkContext context, long size, CLMemoryHandle mem, string tag) -{ - int i = FreeListFindInvalid(ref context); - if (i == context.FreeList.Capacity) - { - var cap = context.FreeList.Capacity; - int new_capacity = cap * 2; - Array.Resize(ref context.FreeList.Entries, new_capacity); - for (int j = 0; j < cap; j++) - { - var entry = new OpenCLFreeListEntry(); - entry.Valid = false; - context.FreeList.Entries[cap + j] = entry; - } - - context.FreeList.Capacity *= 2; - } - - context.FreeList.Entries[i].Valid = true; - context.FreeList.Entries[i].Size = size; - context.FreeList.Entries[i].Tag = tag; - context.FreeList.Entries[i].Mem = mem; - context.FreeList.Used++; -} - -private int FreeListFindInvalid(ref FutharkContext context) -{ - int i; - for (i = 0; i < context.FreeList.Capacity; i++) - { - if (!context.FreeList.Entries[i].Valid) - { - break; - } - } - - return i; -} - -private class OpenCLMemblock -{ - public int References; - public CLMemoryHandle Mem; - public long Size; - public string Tag; - public bool IsNull; - - public void IncreaseRefs() - { - this.References += 1; - } - - public void DecreaseRefs() - { - this.References -= 1; - } -} - -private OpenCLMemblock EmptyMemblock(CLMemoryHandle mem) -{ - var block = new OpenCLMemblock(); - block.Mem = mem; - block.References = 0; - block.Tag = ""; - block.Size = 0; - block.IsNull = true; - - return block; -} - -public struct OpenCLFreeListEntry -{ - public bool Valid; - public CLMemoryHandle Mem; - public long Size; - public string Tag; -} - -public struct OpenCLFreeList -{ - public OpenCLFreeListEntry[] Entries; - public int Capacity; - public int Used; -} - - -private OpenCLFreeList OpenCLFreeListInit() -{ - int CAPACITY = 30; // arbitrarily chosen - var free_list = new OpenCLFreeList(); - free_list.Entries = Enumerable.Range(0, CAPACITY) - .Select(_ => - { - var entry = new OpenCLFreeListEntry(); - entry.Valid = false; - return entry; - }).ToArray(); - - free_list.Capacity = CAPACITY; - free_list.Used = 0; - - return free_list; -} - - -private void OpenCLConfigInit(out OpenCLConfig cfg, - int num_sizes, - string[] size_names, - string[] size_vars, - int[] size_values, - string[] size_classes) -{ - cfg.Debugging = false; - cfg.PreferredDeviceNum = 0; - cfg.PreferredPlatform = ""; - cfg.PreferredDevice = ""; - cfg.DumpProgramTo = null; - cfg.LoadProgramFrom = null; - - // The following are dummy sizes that mean the concrete defaults - // will be set during initialisation via hardware-inspection-based - // heuristics. - cfg.DefaultGroupSize = 0; - cfg.DefaultNumGroups = 0; - cfg.DefaultTileSize = 0; - cfg.DefaultThreshold = 0; - - cfg.NumSizes = num_sizes; - cfg.SizeNames = size_names; - cfg.SizeVars = size_vars; - cfg.SizeValues = size_values; - cfg.SizeClasses = size_classes; -} - -public struct OpenCLContext { - public CLPlatformHandle Platform; - public CLDeviceHandle Device; - public CLContextHandle Context; - public CLCommandQueueHandle Queue; - - public OpenCLConfig Cfg; - - public int MaxGroupSize; - public int MaxNumGroups; - public int MaxTileSize; - public int MaxThreshold; - public int MaxLocalMemory; - public int MaxBespoke; - - public int LockstepWidth; -} - -public struct OpenCLDeviceOption { - public CLPlatformHandle Platform; - public CLDeviceHandle Device; - public ComputeDeviceTypes DeviceType; - public string PlatformName; - public string DeviceName; -}; - -/* This function must be defined by the user. It is invoked by - setup_opencl() after the platform and device has been found, but - before the program is loaded. Its intended use is to tune - constants based on the selected platform and device. */ - -private string OpenCLErrorString(int err) -{ - switch ((ComputeErrorCode) err) { - case ComputeErrorCode.Success: return "Success!"; - case ComputeErrorCode.DeviceNotFound: return "Device not found."; - case ComputeErrorCode.DeviceNotAvailable: return "Device not available"; - case ComputeErrorCode.CompilerNotAvailable: return "Compiler not available"; - case ComputeErrorCode.MemoryObjectAllocationFailure: return "Memory object allocation failure"; - case ComputeErrorCode.OutOfResources: return "Out of resources"; - case ComputeErrorCode.OutOfHostMemory: return "Out of host memory"; - case ComputeErrorCode.ProfilingInfoNotAvailable: return "Profiling information not available"; - case ComputeErrorCode.MemoryCopyOverlap: return "Memory copy overlap"; - case ComputeErrorCode.ImageFormatMismatch: return "Image format mismatch"; - case ComputeErrorCode.ImageFormatNotSupported: return "Image format not supported"; - case ComputeErrorCode.BuildProgramFailure: return "Program build failure"; - case ComputeErrorCode.MapFailure: return "Map failure"; - case ComputeErrorCode.InvalidValue: return "Invalid value"; - case ComputeErrorCode.InvalidDeviceType: return "Invalid device type"; - case ComputeErrorCode.InvalidPlatform: return "Invalid platform"; - case ComputeErrorCode.InvalidDevice: return "Invalid device"; - case ComputeErrorCode.InvalidContext: return "Invalid context"; - case ComputeErrorCode.InvalidCommandQueueFlags: return "Invalid queue properties"; - case ComputeErrorCode.InvalidCommandQueue: return "Invalid command queue"; - case ComputeErrorCode.InvalidHostPointer: return "Invalid host pointer"; - case ComputeErrorCode.InvalidMemoryObject: return "Invalid memory object"; - case ComputeErrorCode.InvalidImageFormatDescriptor: return "Invalid image format descriptor"; - case ComputeErrorCode.InvalidImageSize: return "Invalid image size"; - case ComputeErrorCode.InvalidSampler: return "Invalid sampler"; - case ComputeErrorCode.InvalidBinary: return "Invalid binary"; - case ComputeErrorCode.InvalidBuildOptions: return "Invalid build options"; - case ComputeErrorCode.InvalidProgram: return "Invalid program"; - case ComputeErrorCode.InvalidProgramExecutable: return "Invalid program executable"; - case ComputeErrorCode.InvalidKernelName: return "Invalid kernel name"; - case ComputeErrorCode.InvalidKernelDefinition: return "Invalid kernel definition"; - case ComputeErrorCode.InvalidKernel: return "Invalid kernel"; - case ComputeErrorCode.InvalidArgumentIndex: return "Invalid argument index"; - case ComputeErrorCode.InvalidArgumentValue: return "Invalid argument value"; - case ComputeErrorCode.InvalidArgumentSize: return "Invalid argument size"; - case ComputeErrorCode.InvalidKernelArguments: return "Invalid kernel arguments"; - case ComputeErrorCode.InvalidWorkDimension: return "Invalid work dimension"; - case ComputeErrorCode.InvalidWorkGroupSize: return "Invalid work group size"; - case ComputeErrorCode.InvalidWorkItemSize: return "Invalid work item size"; - case ComputeErrorCode.InvalidGlobalOffset: return "Invalid global offset"; - case ComputeErrorCode.InvalidEventWaitList: return "Invalid event wait list"; - case ComputeErrorCode.InvalidEvent: return "Invalid event"; - case ComputeErrorCode.InvalidOperation: return "Invalid operation"; - case ComputeErrorCode.InvalidGLObject: return "Invalid OpenGL object"; - case ComputeErrorCode.InvalidBufferSize: return "Invalid buffer size"; - case ComputeErrorCode.InvalidMipLevel: return "Invalid mip-map level"; - default: return "Unknown"; - } -} - -private void OpenCLSucceed(int ret, - string call, - string file, - int line) -{ - if (ret != (int) ComputeErrorCode.Success) - { - panic(-1, "{0}:{1}: OpenCL call\n {2}\nfailed with error code {3} ({4})\n", - file, line, call, ret, OpenCLErrorString(ret)); - } -} - -private void SetPreferredPlatform(ref OpenCLConfig cfg, string s) { - cfg.PreferredPlatform = s; -} - -private void SetPreferredDevice(ref OpenCLConfig cfg, string s) -{ - int x = 0; - int i = 0; - if (s[0] == '#') { - i = 1; - while (i < s.Length && char.IsDigit(s[i])) { - x = x * 10 + (int) (s[i])-'0'; - i++; - } - // Skip trailing spaces. - while (i < s.Length && char.IsWhiteSpace(s[i])) { - i++; - } - } - cfg.PreferredDevice = s.Substring(i); - cfg.PreferredDeviceNum = x; -} - -private string OpenCLPlatformInfo(CLPlatformHandle platform, - ComputePlatformInfo param) { - IntPtr req_bytes; - IntPtr _null = new IntPtr(); - OPENCL_SUCCEED(CL10.GetPlatformInfo(platform, param, _null, _null, out req_bytes)); - - byte[] info = new byte[(int) req_bytes]; - unsafe - { - fixed (byte* ptr = &info[0]) - { - OPENCL_SUCCEED(CL10.GetPlatformInfo(platform, param, req_bytes, new IntPtr(ptr), out _null)); - } - } - - return System.Text.Encoding.Default.GetString(info); -} - -private string OpenCLDeviceInfo(CLDeviceHandle device, - ComputeDeviceInfo param) { - IntPtr req_bytes; - IntPtr _null = new IntPtr(); - OPENCL_SUCCEED(CL10.GetDeviceInfo(device, param, _null, _null, out req_bytes)); - - byte[] info = new byte[(int) req_bytes]; - unsafe - { - fixed (byte* ptr = &info[0]) - { - OPENCL_SUCCEED(CL10.GetDeviceInfo(device, param, req_bytes, new IntPtr(ptr), out _null)); - } - } - return System.Text.Encoding.Default.GetString(info); - -} - -private void OpenCLAllDeviceOptions(out OpenCLDeviceOption[] devices_out, - out int num_devices_out) -{ - int num_devices = 0, num_devices_added = 0; - - CLPlatformHandle[] all_platforms; - int[] platform_num_devices; - - int num_platforms; - - // Find the number of platforms. - OPENCL_SUCCEED(CL10.GetPlatformIDs(0, null, out num_platforms)); - - // Make room for them. - all_platforms = new CLPlatformHandle[num_platforms]; - platform_num_devices = new int[num_platforms]; - - int tmp; - // Fetch all the platforms. - OPENCL_SUCCEED(CL10.GetPlatformIDs(num_platforms, all_platforms, out tmp)); - - // Count the number of devices for each platform, as well as the - // total number of devices. - for (int i = 0; i < num_platforms; i++) - { - if (CL10.GetDeviceIDs(all_platforms[i], ComputeDeviceTypes.All, - 0, null, out platform_num_devices[i]) == ComputeErrorCode.Success) - { - num_devices += platform_num_devices[i]; - } - else - { - platform_num_devices[i] = 0; - } - } - - // Make room for all the device options. - OpenCLDeviceOption[] devices = new OpenCLDeviceOption[num_devices]; - - // Loop through the platforms, getting information about their devices. - for (int i = 0; i < num_platforms; i++) { - CLPlatformHandle platform = all_platforms[i]; - int num_platform_devices = platform_num_devices[i]; - - if (num_platform_devices == 0) { - continue; - } - - string platform_name = OpenCLPlatformInfo(platform, ComputePlatformInfo.Name); - CLDeviceHandle[] platform_devices = new CLDeviceHandle[num_platform_devices]; - - // Fetch all the devices. - OPENCL_SUCCEED(CL10.GetDeviceIDs(platform, ComputeDeviceTypes.All, - num_platform_devices, platform_devices, out tmp)); - - IntPtr tmpptr; - // Loop through the devices, adding them to the devices array. - unsafe - { - for (int j = 0; j < num_platform_devices; j++) { - string device_name = OpenCLDeviceInfo(platform_devices[j], ComputeDeviceInfo.Name); - devices[num_devices_added].Platform = platform; - devices[num_devices_added].Device = platform_devices[j]; - fixed (void* ptr = &devices[num_devices_added].DeviceType) - { - OPENCL_SUCCEED(CL10.GetDeviceInfo(platform_devices[j], - ComputeDeviceInfo.Type, - new IntPtr(sizeof(ComputeDeviceTypes)), - new IntPtr(ptr), - out tmpptr)); - } - // We don't want the structs to share memory, so copy the platform name. - // Each device name is already unique. - devices[num_devices_added].PlatformName = platform_name; - devices[num_devices_added].DeviceName = device_name; - num_devices_added++; - } - } - } - - devices_out = devices; - num_devices_out = num_devices; -} - -private bool IsBlacklisted(string platform_name, string device_name) -{ - return (platform_name.Contains("Apple") && - device_name.Contains("Intel(R) Core(TM)")); -} - -private OpenCLDeviceOption GetPreferredDevice(OpenCLConfig cfg) { - OpenCLDeviceOption[] devices; - int num_devices; - - OpenCLAllDeviceOptions(out devices, out num_devices); - - int num_device_matches = 0; - - for (int i = 0; i < num_devices; i++) - { - OpenCLDeviceOption device = devices[i]; - if (!IsBlacklisted(device.PlatformName, device.DeviceName) && - device.PlatformName.Contains(cfg.PreferredPlatform) && - device.DeviceName.Contains(cfg.PreferredDevice) && - num_device_matches++ == cfg.PreferredDeviceNum) - { - return device; - } - } - - panic(1, "Could not find acceptable OpenCL device.\n"); - // this is never reached - throw new Exception(); - -} - -private void DescribeDeviceOption(OpenCLDeviceOption device) { - Console.Error.WriteLine("Using platform: {0}", device.PlatformName); - Console.Error.WriteLine("Using device: {0}", device.DeviceName); -} - -private ComputeProgramBuildStatus BuildOpenCLProgram(ref CLProgramHandle program, CLDeviceHandle device, string options) { - ComputeErrorCode ret_val = CL10.BuildProgram(program, 1, new []{device}, options, null, IntPtr.Zero); - - // Avoid termination due to CL_BUILD_PROGRAM_FAILURE - if (ret_val != ComputeErrorCode.Success && ret_val != ComputeErrorCode.BuildProgramFailure) { - Debug.Assert((int) ret_val == 0); - } - - ComputeProgramBuildStatus build_status; - unsafe - { - IntPtr _null = new IntPtr(); - ret_val = CL10.GetProgramBuildInfo(program, - device, - ComputeProgramBuildInfo.Status, - new IntPtr(sizeof(int)), - new IntPtr(&build_status), - out _null); - } - Debug.Assert(ret_val == 0); - - if (build_status != ComputeProgramBuildStatus.Success) { - char[] build_log; - IntPtr ret_val_size; - unsafe - { - ret_val = CL10.GetProgramBuildInfo(program, - device, - ComputeProgramBuildInfo.BuildLog, - IntPtr.Zero, - IntPtr.Zero, - out ret_val_size); - } - Debug.Assert(ret_val == 0); - - build_log = new char[((int)ret_val_size)+1]; - unsafe - { - IntPtr _null = new IntPtr(); - fixed (char* ptr = &build_log[0]) - { - CL10.GetProgramBuildInfo(program, - device, - ComputeProgramBuildInfo.BuildLog, - ret_val_size, - new IntPtr(ptr), - out _null); - } - } - Debug.Assert(ret_val == 0); - - // The spec technically does not say whether the build log is zero-terminated, so let's be careful. - build_log[(int)ret_val_size] = '\0'; - Console.Error.Write("Build log:\n{0}\n", new string(build_log)); - } - - return build_status; -} - - -// We take as input several strings representing the program, because -// C does not guarantee that the compiler supports particularly large -// literals. Notably, Visual C has a limit of 2048 characters. The -// array must be NULL-terminated. -private CLProgramHandle SetupOpenCL(ref FutharkContext ctx, - string[] srcs, - bool required_types) { - - ComputeErrorCode error; - CLPlatformHandle platform; - CLDeviceHandle device; - int MaxGroupSize, MaxLocalMemory; - - ctx.OpenCL.LockstepWidth = 0; - - OpenCLDeviceOption device_option = GetPreferredDevice(ctx.OpenCL.Cfg); - - if (ctx.Debugging) { - DescribeDeviceOption(device_option); - } - - device = device = device_option.Device; - platform = platform = device_option.Platform; - - if (required_types){ - int supported; - unsafe - { - IntPtr throwaway0 = new IntPtr(); - OPENCL_SUCCEED(CL10.GetDeviceInfo(device, - ComputeDeviceInfo.PreferredVectorWidthDouble, - new IntPtr(sizeof(IntPtr)), - new IntPtr(&supported), - out throwaway0)); - } - if (supported == 0) { - panic(1, - "Program uses double-precision floats, but this is not supported on chosen device: {0}\n", - device_option.DeviceName); - } - } - - unsafe - { - IntPtr throwaway1 = new IntPtr(); - OPENCL_SUCCEED(CL10.GetDeviceInfo(device, - ComputeDeviceInfo.MaxWorkGroupSize, - new IntPtr(sizeof(IntPtr)), - new IntPtr(&MaxGroupSize), - out throwaway1)); - } - - int MaxTileSize = (int) Math.Sqrt(MaxGroupSize); - - unsafe - { - IntPtr throwaway1 = new IntPtr(); - OPENCL_SUCCEED(CL10.GetDeviceInfo(device, - ComputeDeviceInfo.LocalMemorySize, - new IntPtr(sizeof(IntPtr)), - new IntPtr(&MaxLocalMemory), - out throwaway1)); - } - - // Make sure this function is defined. - PostOpenCLSetup(ref ctx, ref device_option); - - if (MaxGroupSize < ctx.OpenCL.Cfg.DefaultGroupSize) { - Console.Error.WriteLine("Note: Device limits default group size to {0} (down from {1}).\n", - MaxGroupSize, ctx.OpenCL.Cfg.DefaultGroupSize); - ctx.OpenCL.Cfg.DefaultGroupSize = MaxGroupSize; - } - - if (MaxTileSize < ctx.OpenCL.Cfg.DefaultTileSize) { - Console.Error.WriteLine("Note: Device limits default tile size to {0} (down from {1}).\n", - MaxTileSize, ctx.OpenCL.Cfg.DefaultTileSize); - ctx.OpenCL.Cfg.DefaultTileSize = MaxTileSize; - } - - ctx.OpenCL.MaxGroupSize = MaxGroupSize; - ctx.OpenCL.MaxTileSize = MaxTileSize; // No limit. - ctx.OpenCL.MaxThreshold = ctx.OpenCL.MaxNumGroups; // No limit. - ctx.OpenCL.MaxLocalMemory = MaxLocalMemory; - ctx.OpenCL.MaxBespoke = 0; // No limit. - - // Now we go through all the sizes, clamp them to the valid range, - // or set them to the default. - for (int i = 0; i < ctx.OpenCL.Cfg.NumSizes; i++) { - string size_class = ctx.OpenCL.Cfg.SizeClasses[i]; - int size_value = ctx.OpenCL.Cfg.SizeValues[i]; - string size_name = ctx.OpenCL.Cfg.SizeNames[i]; - int max_value, default_value; - max_value = default_value = 0; - if (size_class.StartsWith("group_size")) { - max_value = MaxGroupSize; - default_value = ctx.OpenCL.Cfg.DefaultGroupSize; - } else if (size_class.StartsWith("num_groups")) { - max_value = MaxGroupSize; // Futhark assumes this constraint. - default_value = ctx.OpenCL.Cfg.DefaultNumGroups; - } else if (size_class.StartsWith("tile_size")){ - max_value = (int) Math.Sqrt(MaxGroupSize); - default_value = ctx.OpenCL.Cfg.DefaultTileSize; - } else if (size_class.StartsWith("threshold")) { - max_value = 0; // No limit. - default_value = ctx.OpenCL.Cfg.DefaultThreshold; - } else { - // Bespoke sizes have no limit or default. - max_value = 0; - } - if (size_value == 0) { - ctx.OpenCL.Cfg.SizeValues[i] = default_value; - } else if (max_value > 0 && size_value > max_value) { - Console.Error.WriteLine("Note: Device limits {0} to {1} (down from {2})", - size_name, max_value, size_value); - ctx.OpenCL.Cfg.SizeValues[i] = default_value; - } - } - - IntPtr[] properties = new []{ - new IntPtr((int) ComputeContextInfo.Platform), - platform.Value, - IntPtr.Zero - }; - // Note that nVidia's OpenCL requires the platform property - IntPtr _null; - ctx.OpenCL.Context = CL10.CreateContext(properties, 1, new []{device}, null, ctx.NULL, out error); - Debug.Assert(error == 0); - - ctx.OpenCL.Queue = CL10.CreateCommandQueue(ctx.OpenCL.Context, device, 0, out error); - Debug.Assert(error == 0); - - if (ctx.Debugging) { - Console.Error.WriteLine("Lockstep width: {0}\n", (int)ctx.OpenCL.LockstepWidth); - Console.Error.WriteLine("Default group size: {0}\n", (int)ctx.OpenCL.Cfg.DefaultGroupSize); - Console.Error.WriteLine("Default number of groups: {0}\n", (int)ctx.OpenCL.Cfg.DefaultNumGroups); - } - - string fut_opencl_src; - - // Maybe we have to read OpenCL source from somewhere else (used for debugging). - if (ctx.OpenCL.Cfg.LoadProgramFrom != null) { - fut_opencl_src = File.ReadAllText(ctx.OpenCL.Cfg.LoadProgramFrom); - } else { - // Build the OpenCL program. First we have to concatenate all the fragments. - fut_opencl_src = string.Join("\n", srcs); - } - - CLProgramHandle prog; - error = 0; - string[] src_ptr = new[]{fut_opencl_src}; - IntPtr[] src_size = new []{IntPtr.Zero}; - - if (ctx.OpenCL.Cfg.DumpProgramTo != null) { - File.WriteAllText(ctx.OpenCL.Cfg.DumpProgramTo, fut_opencl_src); - } - - unsafe - { - prog = CL10.CreateProgramWithSource(ctx.OpenCL.Context, 1, src_ptr, src_size, out error); - } - Debug.Assert(error == 0); - - int compile_opts_size = 1024; - - string compile_opts = String.Format("-DLOCKSTEP_WIDTH={0} ", - ctx.OpenCL.LockstepWidth); - - for (int i = 0; i < ctx.OpenCL.Cfg.NumSizes; i++) { - compile_opts += String.Format("-D{0}={1} ", - ctx.OpenCL.Cfg.SizeVars[i], - ctx.OpenCL.Cfg.SizeValues[i]); - } - - OPENCL_SUCCEED(BuildOpenCLProgram(ref prog, device, compile_opts)); - - return prog; -} - -private CLMemoryHandle EmptyMemHandle(CLContextHandle context) -{ - ComputeErrorCode tmp; - var cl_mem = CL10.CreateBuffer(context, ComputeMemoryFlags.ReadWrite, - IntPtr.Zero, IntPtr.Zero, - out tmp); - return cl_mem; - -} - -private void FutharkConfigPrintSizes() -{ - int n = FutharkGetNumSizes(); - for (int i = 0; i < n; i++) - { - Console.WriteLine("{0} ({1})", FutharkGetSizeName(i), - FutharkGetSizeClass(i)); - } - Environment.Exit(0); -} - -private void FutharkConfigSetSize(ref FutharkContextConfig config, string optarg) -{ - var name_and_value = optarg.Split('='); - if (name_and_value.Length != 2) - { - panic(1, "Invalid argument for size option: {0}", optarg); - } - - var name = name_and_value[0]; - var value = Convert.ToInt32(name_and_value[1]); - if (name == "default_num_groups") { - config.OpenCL.DefaultNumGroups = value; - } - else if (name == "default_group_size") { - config.OpenCL.DefaultGroupSize = value; - } - else if (name == "default_tile_size") { - config.OpenCL.DefaultTileSize = value; - } - else if (name == "default_threshold") { - config.OpenCL.DefaultThreshold = value; - } - else if (!FutharkContextConfigSetSize(ref config, name, value)) - { - panic(1, "Unknown size: {0}", name); - } -} - -private void FutharkConfigLoadTuning(ref FutharkContextConfig config, string fname) -{ - StreamReader file = new StreamReader(fname); - String line; - while((line = file.ReadLine()) != null) - { - FutharkConfigSetSize(ref config, line); - } - file.Close(); -} diff --git a/rts/csharp/panic.cs b/rts/csharp/panic.cs deleted file mode 100644 --- a/rts/csharp/panic.cs +++ /dev/null @@ -1,24 +0,0 @@ -private void panic(int exitcode, string str, params Object[] args) -{ - var prog_name = Environment.GetCommandLineArgs()[0]; - Console.Error.WriteLine(String.Format("{0}:", prog_name)); - Console.Error.WriteLine(String.Format(str, args)); - Environment.Exit(exitcode); -} - -private void FutharkAssert(bool assertion) -{ - if (!assertion) - { - Environment.Exit(1); - } -} - -private void FutharkAssert(bool assertion, string errorMsg) -{ - if (!assertion) - { - Console.Error.WriteLine(errorMsg); - Environment.Exit(1); - } -} diff --git a/rts/csharp/reader.cs b/rts/csharp/reader.cs deleted file mode 100644 --- a/rts/csharp/reader.cs +++ /dev/null @@ -1,885 +0,0 @@ -private Stream s; -private BinaryReader b; - -// Note that the lookahead buffer does not interact well with -// binary reading. We are careful to not let this become a -// problem. -private Stack LookaheadBuffer = new Stack(); - -private void ResetLookahead(){ - LookaheadBuffer.Clear(); -} - -private void ValueReader(Stream s) -{ - this.s = s; -} - -private void ValueReader() -{ - this.s = Console.OpenStandardInput(); - this.b = new BinaryReader(s); -} - -private char? GetChar() -{ - char c; - if (LookaheadBuffer.Count == 0) - { - c = (char) this.b.ReadByte(); - } - else - { - c = LookaheadBuffer.Pop(); - } - - return c; -} - -private char[] GetChars(int n) -{ - return Enumerable.Range(0, n).Select(_ => GetChar().Value).ToArray(); -} - -private void UngetChar(char c) -{ - LookaheadBuffer.Push(c); -} - -private char PeekChar() -{ - var c = GetChar(); - UngetChar(c.Value); - return c.Value; -} - -private void SkipSpaces() -{ - var c = GetChar(); - while (c.HasValue){ - if (char.IsWhiteSpace(c.Value)) - { - c = GetChar(); - } - else if (c == '-') - { - if (PeekChar() == '-') - { - while (c.Value != '\n') - { - c = GetChar(); - } - } - else - { - break; - } - } - else - { - break; - } - } - - if (c.HasValue) - { - UngetChar(c.Value); - } -} - -private bool ParseSpecificChar(char c) -{ - var got = GetChar(); - if (got.Value != c) - { - UngetChar(got.Value); - throw new ValueError(); - } - return true; -} - -private bool ParseSpecificString(string str) -{ - var read = new List(); - foreach (var c in str.ToCharArray()) - { - try - { - ParseSpecificChar(c); - read.Add(c); - } - catch(ValueError) - { - read.Reverse(); - foreach (var cc in read) - { - UngetChar(cc); - } - throw; - } - } - - return true; -} - -private string Optional(Func p) -{ - string res = null; - try - { - res = p(); - } - catch (Exception) - { - } - - return res; -} - -private bool Optional(Func p, char c) -{ - try - { - return p(c); - } - catch (Exception) - { - } - - return false; -} - -private bool OptionalSpecificString(string s) -{ - var c = PeekChar(); - if (c == s[0]) - { - return ParseSpecificString(s); - } - return false; -} - - -private List sepBy(Func p, Func sep) -{ - var elems = new List(); - var x = Optional(p); - if (!string.IsNullOrWhiteSpace(x)) - { - elems.Add(x); - while (!string.IsNullOrWhiteSpace(Optional(sep))) - { - var y = Optional(p); - elems.Add(y); - } - } - return elems; -} - -private string ParseHexInt() -{ - var s = ""; - var c = GetChar(); - while (c.HasValue) - { - if (Uri.IsHexDigit(c.Value)) - { - s += c.Value; - c = GetChar(); - } - else if (c == '_') - { - c = GetChar(); - } - else - { - UngetChar(c.Value); - break; - } - } - - return Convert.ToString(Convert.ToUInt32(s, 16)); -} - -private string ParseInt() -{ - var s = ""; - var c = GetChar(); - if (c.Value == '0' && "xX".Contains(PeekChar())) - { - GetChar(); - s += ParseHexInt(); - } - else - { - while (c.HasValue) - { - if (char.IsDigit(c.Value)) - { - s += c.Value; - c = GetChar(); - }else if (c == '_') - { - c = GetChar(); - } - else - { - UngetChar(c.Value); - break; - } - } - - } - - if (s.Length == 0) - { - throw new Exception("ValueError"); - } - - return s; -} - -private string ParseIntSigned() -{ - var c = GetChar(); - if (c.Value == '-' && char.IsDigit(PeekChar())) - { - return c + ParseInt(); - } - else - { - if (c.Value != '+') - { - UngetChar(c.Value); - } - - return ParseInt(); - } -} - -private string ReadStrComma() -{ - SkipSpaces(); - ParseSpecificChar(','); - return ","; -} - -private int ReadStrInt(string s) -{ - SkipSpaces(); - var x = Convert.ToInt32(ParseIntSigned()); - OptionalSpecificString(s); - return x; -} - -private ulong ReadStrUInt64(string s) -{ - SkipSpaces(); - var x = Convert.ToUInt64(ParseInt()); - OptionalSpecificString(s); - return x; -} - -private long ReadStrInt64(string s) -{ - SkipSpaces(); - var x = Convert.ToInt64(ParseIntSigned()); - OptionalSpecificString(s); - return x; -} - -private uint ReadStrUInt(string s) -{ - SkipSpaces(); - var x = Convert.ToUInt32(ParseInt()); - OptionalSpecificString(s); - return x; -} - -private int ReadStrI8(){return ReadStrInt("i8");} -private int ReadStrI16(){return ReadStrInt("i16");} -private int ReadStrI32(){return ReadStrInt("i32");} -private long ReadStrI64(){return ReadStrInt64("i64");} -private uint ReadStrU8(){return ReadStrUInt("u8");} -private uint ReadStrU16(){return ReadStrUInt("u16");} -private uint ReadStrU32(){return ReadStrUInt("u32");} -private ulong ReadStrU64(){return ReadStrUInt64("u64");} -private sbyte ReadBinI8(){return (sbyte) b.ReadByte();} -private short ReadBinI16(){return b.ReadInt16();} -private int ReadBinI32(){return b.ReadInt32();} -private long ReadBinI64(){return b.ReadInt64();} -private byte ReadBinU8(){return (byte) b.ReadByte();} -private ushort ReadBinU16(){return b.ReadUInt16();} -private uint ReadBinU32(){return b.ReadUInt32();} -private ulong ReadBinU64(){return b.ReadUInt64();} -private float ReadBinF32(){return b.ReadSingle();} -private double ReadBinF64(){return b.ReadDouble();} -private bool ReadBinBool(){return b.ReadBoolean();} - -private char ReadChar() -{ - SkipSpaces(); - ParseSpecificChar('\''); - var c = GetChar(); - ParseSpecificChar('\''); - return c.Value; -} - -private double ReadStrHexFloat(char sign) -{ - var int_part = ParseHexInt(); - ParseSpecificChar('.'); - var frac_part = ParseHexInt(); - ParseSpecificChar('p'); - var exponent = ParseHexInt(); - - var int_val = Convert.ToInt32(int_part, 16); - var frac_val = Convert.ToSingle(Convert.ToInt32(frac_part, 16)) / Math.Pow(16, frac_part.Length); - var exp_val = Convert.ToInt32(exponent); - - var total_val = (int_val + frac_val) * Math.Pow(2, exp_val); - if (sign == '-') - { - total_val = -1 * total_val; - } - - return Convert.ToDouble(total_val); -} - -private double ReadStrDecimal() -{ - SkipSpaces(); - var c = GetChar(); - char sign; - if (c.Value == '-') - { - sign = '-'; - } - else - { - UngetChar(c.Value); - sign = '+'; - } - - // Check for hexadecimal float - c = GetChar(); - if (c.Value == '0' && "xX".Contains(PeekChar())) - { - GetChar(); - return ReadStrHexFloat(sign); - } - else - { - UngetChar(c.Value); - } - - var bef = Optional(this.ParseInt); - var aft = ""; - if (string.IsNullOrEmpty(bef)) - { - bef = "0"; - ParseSpecificChar('.'); - aft = ParseInt(); - }else if (Optional(ParseSpecificChar, '.')) - { - aft = ParseInt(); - } - else - { - aft = "0"; - } - - var expt = ""; - if (Optional(ParseSpecificChar, 'E') || - Optional(ParseSpecificChar, 'e')) - { - expt = ParseIntSigned(); - } - else - { - expt = "0"; - } - - return Convert.ToDouble(sign + bef + "." + aft + "E" + expt); -} - -private float ReadStrF32() -{ - try - { - ParseSpecificString("f32.nan"); - return Single.NaN; - } - catch (ValueError) - { - try - { - ParseSpecificString("-f32.inf"); - return Single.NegativeInfinity; - } - catch (ValueError) - { - try - { - ParseSpecificString("f32.inf"); - return Single.PositiveInfinity; - } - catch (ValueError) - { - var x = ReadStrDecimal(); - OptionalSpecificString("f32"); - return Convert.ToSingle(x); - } - } - } -} - -private double ReadStrF64() -{ - try - { - ParseSpecificString("f64.nan"); - return Double.NaN; - } - catch (ValueError) - { - try - { - ParseSpecificString("-f64.inf"); - return Double.NegativeInfinity; - } - catch (ValueError) - { - try - { - ParseSpecificString("f64.inf"); - return Double.PositiveInfinity; - } - catch (ValueError) - { - var x = ReadStrDecimal(); - OptionalSpecificString("f64"); - return x; - } - } - } -} -private bool ReadStrBool() -{ - SkipSpaces(); - if (PeekChar() == 't') - { - ParseSpecificString("true"); - return true; - } - - if (PeekChar() == 'f') - { - ParseSpecificString("false"); - return false; - } - - throw new ValueError(); -} - -private (T[], int[]) ReadStrArrayElems(int rank, Func ReadStrScalar) -{ - bool first = true; - bool[] knows_dimsize = new bool[rank]; - int cur_dim = rank-1; - int[] elems_read_in_dim = new int[rank]; - int[] shape = new int[rank]; - - int capacity = 100; - T[] data = new T[capacity]; - int write_ptr = 0; - - while (true) { - SkipSpaces(); - - char c = (char) GetChar(); - if (c == ']') { - if (knows_dimsize[cur_dim]) { - if (shape[cur_dim] != elems_read_in_dim[cur_dim]) { - throw new Exception("Irregular array"); - } - } else { - knows_dimsize[cur_dim] = true; - shape[cur_dim] = elems_read_in_dim[cur_dim]; - } - if (cur_dim == 0) { - break; - } else { - cur_dim--; - elems_read_in_dim[cur_dim]++; - } - } else if (c == ',') { - SkipSpaces(); - c = (char) GetChar(); - if (c == '[') { - if (cur_dim == rank - 1) { - throw new Exception("Array has too many dimensions"); - } - first = true; - cur_dim++; - elems_read_in_dim[cur_dim] = 0; - } else if (cur_dim == rank - 1) { - UngetChar(c); - - data[write_ptr++] = ReadStrScalar(); - if (write_ptr == capacity) { - capacity *= 2; - Array.Resize(ref data, capacity); - } - elems_read_in_dim[cur_dim]++; - } else { - throw new Exception("Unexpected comma when reading array"); - } - } else if (first) { - if (c == '[') { - if (cur_dim == rank - 1) { - throw new Exception("Array has too many dimensions"); - } - cur_dim++; - elems_read_in_dim[cur_dim] = 0; - } else { - UngetChar(c); - data[write_ptr++] = ReadStrScalar(); - if (write_ptr == capacity) { - capacity *= 2; - Array.Resize(ref data, capacity); - } - elems_read_in_dim[cur_dim]++; - first = false; - } - } else { - throw new Exception("Unexpected character in array"); - } - } - Array.Resize(ref data, write_ptr); - return (data, shape); -} - -private (T[], int[]) ReadStrArrayEmpty(int rank, string typeName, Func ReadStrScalar) -{ - ParseSpecificString("empty"); - ParseSpecificChar('('); - int[] shape = new int[rank]; - for (int i = 0; i < rank; i++) { - ParseSpecificString("["); - shape[i] = Convert.ToInt32(ParseIntSigned()); - ParseSpecificString("]"); - } - ParseSpecificString(typeName); - ParseSpecificChar(')'); - - // Check whether the array really is empty. - for (int i = 0; i < rank; i++) { - if (shape[i] == 0) { - return (new T[1], shape); - } - } - - // Not an empty array! - throw new Exception("empty() used with nonempty shape"); -} - -private (T[], int[]) ReadStrArray(int rank, string typeName, Func ReadStrScalar) -{ - long read_dims = 0; - - while (true) { - SkipSpaces(); - var c = GetChar(); - if (c=='[') { - read_dims++; - } else { - if (c != null) { - UngetChar((char)c); - } - break; - } - } - - if (read_dims == 0) { - return ReadStrArrayEmpty(rank, typeName, ReadStrScalar); - } - - if (read_dims != rank) { - throw new Exception("Wrong number of dimensions"); - } - - return ReadStrArrayElems(rank, ReadStrScalar); -} - -private Dictionary primtypes = new Dictionary -{ - {" i8", "i8"}, - {" i16", "i16"}, - {" i32", "i32"}, - {" i64", "i64"}, - {" u8", "u8"}, - {" u16", "u16"}, - {" u32", "u32"}, - {" u64", "u64"}, - {" f32", "f32"}, - {" f64", "f64"}, - {"bool", "bool"} -}; - -private int BINARY_FORMAT_VERSION = 2; - - -private void read_le_2byte(ref short dest) -{ - dest = b.ReadInt16(); -} - -private void read_le_4byte(ref int dest) -{ - dest = b.ReadInt32(); -} - -private void read_le_8byte(ref long dest) -{ - dest = b.ReadInt64(); -} - -private bool ReadIsBinary() - { - SkipSpaces(); - var c = GetChar(); - if (c == 'b') - { - byte bin_version = new byte(); - try - { - bin_version = (byte) b.ReadByte(); - } - catch - { - Console.WriteLine("binary-input: could not read version"); - Environment.Exit(1); - } - - if (bin_version != BINARY_FORMAT_VERSION) - { - Console.WriteLine(( - "binary-input: File uses version {0}, but I only understand version {1}.", bin_version, - BINARY_FORMAT_VERSION)); - Environment.Exit(1); - } - - return true; - } - UngetChar((char) c); - return false; - } - -private (T[], int[]) ReadArray(int rank, string typeName, Func ReadStrScalar) -{ - if (!ReadIsBinary()) - { - return ReadStrArray(rank, typeName, ReadStrScalar); - } - else - { - return ReadBinArray(rank, typeName, ReadStrScalar); - } -} -private T ReadScalar(string typeName, Func ReadStrScalar, Func ReadBinScalar) -{ - if (!ReadIsBinary()) - { - return ReadStrScalar(); - } - else - { - ReadBinEnsureScalar(typeName); - return ReadBinScalar(); - } -} - -private void ReadBinEnsureScalar(string typeName) -{ - var bin_dims = b.ReadByte(); - if (bin_dims != 0) - { - Console.WriteLine("binary-input: Expected scalar (0 dimensions), but got array with {0} dimensions.", bin_dims); - Environment.Exit(1); - } - - var bin_type = ReadBinReadTypeString(); - if (bin_type != typeName) - { - Console.WriteLine("binary-input: Expected scalar of type {0} but got scalar of type {1}.", typeName, - bin_type); - Environment.Exit(1); - } -} - -private string ReadBinReadTypeString() -{ - var str_bytes = b.ReadBytes(4); - var str = System.Text.Encoding.UTF8.GetString(str_bytes, 0, 4); - return primtypes[str]; -} - -private (T[], int[]) ReadBinArray(int rank, string typeName, Func ReadStrScalar) -{ - var bin_dims = new int(); - var shape = new int[rank]; - try - { - bin_dims = b.ReadByte(); - } - catch - { - Console.WriteLine("binary-input: Couldn't get dims."); - Environment.Exit(1); - } - - if (bin_dims != rank) - { - Console.WriteLine("binary-input: Expected {0} dimensions, but got array with {1} dimensions", rank, - bin_dims); - Environment.Exit(1); - - } - - var bin_primtype = ReadBinReadTypeString(); - if (typeName != bin_primtype) - { - Console.WriteLine("binary-input: Expected {0}D-array with element type '{1}', but got {2}D-array with element type '{3}'.", - rank, typeName, bin_dims, bin_primtype); - Environment.Exit(1); - } - - int elem_count = 1; - for (var i = 0; i < rank; i++) - { - long bin_shape = new long(); - try - { - read_le_8byte(ref bin_shape); - } - catch - { - Console.WriteLine("binary-input: Couldn't read size for dimension {0} of array.", i); - Environment.Exit(1); - } - - elem_count *= (int) bin_shape; - shape[i] = (int) bin_shape; - } - - // For whatever reason, Marshal.SizeOf is 4, so special-case that here. - var elem_size = typeof(T) == typeof(bool) ? 1 : Marshal.SizeOf(); - var num_bytes = elem_count * elem_size; - var tmp = new byte[num_bytes]; - var data = new T[elem_count]; - - var to_read = num_bytes; - var have_read = 0; - while (to_read > 0) - { - var bytes_read = b.Read(tmp, have_read, to_read); - to_read -= bytes_read; - have_read += bytes_read; - if (bytes_read == 0) { - Console.WriteLine("binary-input: EOF after {0} bytes (expected {1})", have_read, num_bytes); - Environment.Exit(1); - } - } - - if (!BitConverter.IsLittleEndian && elem_size != 1) - { - for (int i = 0; i < elem_count; i ++) - { - Array.Reverse(tmp, i * elem_size, elem_size); - } - } - Buffer.BlockCopy(tmp,0,data,0,num_bytes); - - /* we should have a proper error message here */ - return (data, shape); -} - - -private sbyte ReadI8() -{ - return (sbyte) ReadStrI8(); -} -private short ReadI16() -{ - return (short) ReadStrI16(); -} -private int ReadI32() -{ - return ReadStrI32(); -} -private long ReadI64() -{ - return ReadStrI64(); -} - -private byte ReadU8() -{ - return (byte) ReadStrU8(); -} -private ushort ReadU16() -{ - return (ushort) ReadStrU16(); -} -private uint ReadU32() -{ - return (uint) ReadStrU32(); -} -private ulong ReadU64() -{ - return (ulong) ReadStrU64(); -} -private bool ReadBool() -{ - return ReadStrBool(); -} -private float ReadF32() -{ - return ReadStrF32(); -} -private double ReadF64() -{ - return ReadStrF64(); -} - -private void EndOfInput(string entry) -{ - try { - SkipSpaces(); - var c = GetChar(); - if (c.HasValue) { - throw new Exception(String.Format("Expected EOF on stdin after reading input for \"{0}\".", entry)); - } - } catch (System.IO.EndOfStreamException e) { - } -} - -private void WriteValue(bool x){Console.Write(x ? "true" : "false", x);} -private void WriteValue(sbyte x){Console.Write("{0}i8", x);} -private void WriteValue(short x){Console.Write("{0}i16", x);} -private void WriteValue(int x){Console.Write("{0}i32", x);} -private void WriteValue(long x){Console.Write("{0}i64", x);} -private void WriteValue(byte x){Console.Write("{0}u8", x);} -private void WriteValue(ushort x){Console.Write("{0}u16", x);} -private void WriteValue(uint x){Console.Write("{0}u32", x);} -private void WriteValue(ulong x){Console.Write("{0}u64", x);} -private void WriteValue(float x){if (Single.IsNaN(x)) - {Console.Write("f32.nan");} else if (Single.IsNegativeInfinity(x)) - {Console.Write("-f32.inf");} else if (Single.IsPositiveInfinity(x)) - {Console.Write("f32.inf");} else - {Console.Write("{0:0.000000}f32", x);}} -private void WriteValue(double x){if (Double.IsNaN(x)) - {Console.Write("f64.nan");} else if (Double.IsNegativeInfinity(x)) - {Console.Write("-f64.inf");} else if (Double.IsPositiveInfinity(x)) - {Console.Write("f64.inf");} else - {Console.Write("{0:0.000000}f64", x);}} diff --git a/rts/csharp/scalar.cs b/rts/csharp/scalar.cs deleted file mode 100644 --- a/rts/csharp/scalar.cs +++ /dev/null @@ -1,484 +0,0 @@ -// Scalar functions. -private static sbyte signed(byte x){ return (sbyte) x;} -private static short signed(ushort x){ return (short) x;} -private static int signed(uint x){ return (int) x;} -private static long signed(ulong x){ return (long) x;} - -private static byte unsigned(sbyte x){ return (byte) x;} -private static ushort unsigned(short x){ return (ushort) x;} -private static uint unsigned(int x){ return (uint) x;} -private static ulong unsigned(long x){ return (ulong) x;} - -private static sbyte add8(sbyte x, sbyte y){ return (sbyte) ((byte) x + (byte) y);} -private static short add16(short x, short y){ return (short) ((ushort) x + (ushort) y);} -private static int add32(int x, int y){ return (int) ((uint) x + (uint) y);} -private static long add64(long x, long y){ return (long) ((ulong) x + (ulong) y);} - -private static sbyte add_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x + (byte) y);} -private static short add_nw16(short x, short y){ return (short) ((ushort) x + (ushort) y);} -private static int add_nw32(int x, int y){ return (int) ((uint) x + (uint) y);} -private static long add_nw64(long x, long y){ return (long) ((ulong) x + (ulong) y);} - -private static sbyte sub8(sbyte x, sbyte y){ return (sbyte) ((byte) x - (byte) y);} -private static short sub16(short x, short y){ return (short) ((ushort) x - (ushort) y);} -private static int sub32(int x, int y){ return (int) ((uint) x - (uint) y);} -private static long sub64(long x, long y){ return (long) ((ulong) x - (ulong) y);} - -private static sbyte sub_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x - (byte) y);} -private static short sub_nw16(short x, short y){ return (short) ((ushort) x - (ushort) y);} -private static int sub_nw32(int x, int y){ return (int) ((uint) x - (uint) y);} -private static long sub_nw64(long x, long y){ return (long) ((ulong) x - (ulong) y);} - -private static sbyte mul8(sbyte x, sbyte y){ return (sbyte) ((byte) x * (byte) y);} -private static short mul16(short x, short y){ return (short) ((ushort) x * (ushort) y);} -private static int mul32(int x, int y){ return (int) ((uint) x * (uint) y);} -private static long mul64(long x, long y){ return (long) ((ulong) x * (ulong) y);} - -private static sbyte mul_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x * (byte) y);} -private static short mul_nw16(short x, short y){ return (short) ((ushort) x * (ushort) y);} -private static int mul_nw32(int x, int y){ return (int) ((uint) x * (uint) y);} -private static long mul_nw64(long x, long y){ return (long) ((ulong) x * (ulong) y);} - -private static sbyte or8(sbyte x, sbyte y){ return (sbyte) (x | y); } -private static short or16(short x, short y){ return (short) (x | y); } -private static int or32(int x, int y){ return x | y; } -private static long or64(long x, long y){ return x | y;} - -private static sbyte xor8(sbyte x, sbyte y){ return (sbyte) (x ^ y); } -private static short xor16(short x, short y){ return (short) (x ^ y); } -private static int xor32(int x, int y){ return x ^ y; } -private static long xor64(long x, long y){ return x ^ y;} - -private static sbyte and8(sbyte x, sbyte y){ return (sbyte) (x & y); } -private static short and16(short x, short y){ return (short) (x & y); } -private static int and32(int x, int y){ return x & y; } -private static long and64(long x, long y){ return x & y;} - -private static sbyte shl8(sbyte x, sbyte y){ return (sbyte) (x << y); } -private static short shl16(short x, short y){ return (short) (x << y); } -private static int shl32(int x, int y){ return x << y; } -private static long shl64(long x, long y){ return x << Convert.ToInt32(y); } - -private static sbyte ashr8(sbyte x, sbyte y){ return (sbyte) (x >> y); } -private static short ashr16(short x, short y){ return (short) (x >> y); } -private static int ashr32(int x, int y){ return x >> y; } -private static long ashr64(long x, long y){ return x >> Convert.ToInt32(y); } - -private static sbyte sdiv8(sbyte x, sbyte y){ - var q = squot8(x,y); - var r = srem8(x,y); - return (sbyte) (q - (((r != (sbyte) 0) && ((r < (sbyte) 0) != (y < (sbyte) 0))) ? (sbyte) 1 : (sbyte) 0)); -} -private static short sdiv16(short x, short y){ - var q = squot16(x,y); - var r = srem16(x,y); - return (short) (q - (((r != (short) 0) && ((r < (short) 0) != (y < (short) 0))) ? (short) 1 : (short) 0)); -} -private static int sdiv32(int x, int y){ - var q = squot32(x,y); - var r = srem32(x,y); - return q - (((r != (int) 0) && ((r < (int) 0) != (y < (int) 0))) ? (int) 1 : (int) 0); -} -private static long sdiv64(long x, long y){ - var q = squot64(x,y); - var r = srem64(x,y); - return q - (((r != (long) 0) && ((r < (long) 0) != (y < (long) 0))) ? (long) 1 : (long) 0); -} - -private static sbyte smod8(sbyte x, sbyte y){ - var r = srem8(x,y); - return (sbyte) (r + ((r == (sbyte) 0 || (x > (sbyte) 0 && y > (sbyte) 0) || (x < (sbyte) 0 && y < (sbyte) 0)) ? (sbyte) 0 : y)); -} -private static short smod16(short x, short y){ - var r = srem16(x,y); - return (short) (r + ((r == (short) 0 || (x > (short) 0 && y > (short) 0) || (x < (short) 0 && y < (short) 0)) ? (short) 0 : y)); -} -private static int smod32(int x, int y){ - var r = srem32(x,y); - return (int) r + ((r == (int) 0 || (x > (int) 0 && y > (int) 0) || (x < (int) 0 && y < (int) 0)) ? (int) 0 : y); -} -private static long smod64(long x, long y){ - var r = srem64(x,y); - return (long) r + ((r == (long) 0 || (x > (long) 0 && y > (long) 0) || (x < (long) 0 && y < (long) 0)) ? (long) 0 : y); -} - -private static sbyte udiv8(sbyte x, sbyte y){ return signed((byte) (unsigned(x) / unsigned(y))); } -private static short udiv16(short x, short y){ return signed((ushort) (unsigned(x) / unsigned(y))); } -private static int udiv32(int x, int y){ return signed(unsigned(x) / unsigned(y)); } -private static long udiv64(long x, long y){ return signed(unsigned(x) / unsigned(y)); } - -private static sbyte umod8(sbyte x, sbyte y){ return signed((byte) (unsigned(x) % unsigned(y))); } -private static short umod16(short x, short y){ return signed((ushort) (unsigned(x) % unsigned(y))); } -private static int umod32(int x, int y){ return signed(unsigned(x) % unsigned(y)); } -private static long umod64(long x, long y){ return signed(unsigned(x) % unsigned(y)); } - -private static sbyte squot8(sbyte x, sbyte y){ return (sbyte) Math.Truncate(ToSingle(x) / ToSingle(y)); } -private static short squot16(short x, short y){ return (short) Math.Truncate(ToSingle(x) / ToSingle(y)); } -private static int squot32(int x, int y){ return (int) Math.Truncate(ToSingle(x) / ToSingle(y)); } -private static long squot64(long x, long y){ return (long) Math.Truncate(ToSingle(x) / ToSingle(y)); } - -// private static Maybe change srem, it calls np.fmod originally so i dont know -private static sbyte srem8(sbyte x, sbyte y){ return (sbyte) ((sbyte) x % (sbyte) y);} -private static short srem16(short x, short y){ return (short) ((short) x % (short) y);} -private static int srem32(int x, int y){ return (int) ((int) x % (int) y);} -private static long srem64(long x, long y){ return (long) ((long) x % (long) y);} - -private static sbyte smin8(sbyte x, sbyte y){ return Math.Min(x,y);} -private static short smin16(short x, short y){ return Math.Min(x,y);} -private static int smin32(int x, int y){ return Math.Min(x,y);} -private static long smin64(long x, long y){ return Math.Min(x,y);} - -private static sbyte smax8(sbyte x, sbyte y){ return Math.Max(x,y);} -private static short smax16(short x, short y){ return Math.Max(x,y);} -private static int smax32(int x, int y){ return Math.Max(x,y);} -private static long smax64(long x, long y){ return Math.Max(x,y);} - -private static sbyte umin8(sbyte x, sbyte y){ return signed(Math.Min(unsigned(x),unsigned(y)));} -private static short umin16(short x, short y){ return signed(Math.Min(unsigned(x),unsigned(y)));} -private static int umin32(int x, int y){ return signed(Math.Min(unsigned(x),unsigned(y)));} -private static long umin64(long x, long y){ return signed(Math.Min(unsigned(x),unsigned(y)));} - -private static sbyte umax8(sbyte x, sbyte y){ return signed(Math.Max(unsigned(x),unsigned(y)));} -private static short umax16(short x, short y){ return signed(Math.Max(unsigned(x),unsigned(y)));} -private static int umax32(int x, int y){ return signed(Math.Max(unsigned(x),unsigned(y)));} -private static long umax64(long x, long y){ return signed(Math.Max(unsigned(x),unsigned(y)));} - -private static float fmin32(float x, float y){ return Math.Min(x,y);} -private static double fmin64(double x, double y){ return Math.Min(x,y);} -private static float fmax32(float x, float y){ return Math.Max(x,y);} -private static double fmax64(double x, double y){ return Math.Max(x,y);} - -private static sbyte pow8(sbyte x, sbyte y){sbyte res = 1;for (var i = 0; i < y; i++){res *= x;}return res;} -private static short pow16(short x, short y){short res = 1;for (var i = 0; i < y; i++){res *= x;}return res;} -private static int pow32(int x, int y){int res = 1;for (var i = 0; i < y; i++){res *= x;}return res;} -private static long pow64(long x, long y){long res = 1;for (var i = 0; i < y; i++){res *= x;}return res;} - -private static float fpow32(float x, float y){ return Convert.ToSingle(Math.Pow(x,y));} -private static double fpow64(double x, double y){ return Convert.ToDouble(Math.Pow(x,y));} - -private static bool sle8(sbyte x, sbyte y){ return x <= y ;} -private static bool sle16(short x, short y){ return x <= y ;} -private static bool sle32(int x, int y){ return x <= y ;} -private static bool sle64(long x, long y){ return x <= y ;} - -private static bool slt8(sbyte x, sbyte y){ return x < y ;} -private static bool slt16(short x, short y){ return x < y ;} -private static bool slt32(int x, int y){ return x < y ;} -private static bool slt64(long x, long y){ return x < y ;} - -private static bool ule8(sbyte x, sbyte y){ return unsigned(x) <= unsigned(y) ;} -private static bool ule16(short x, short y){ return unsigned(x) <= unsigned(y) ;} -private static bool ule32(int x, int y){ return unsigned(x) <= unsigned(y) ;} -private static bool ule64(long x, long y){ return unsigned(x) <= unsigned(y) ;} - -private static bool ult8(sbyte x, sbyte y){ return unsigned(x) < unsigned(y) ;} -private static bool ult16(short x, short y){ return unsigned(x) < unsigned(y) ;} -private static bool ult32(int x, int y){ return unsigned(x) < unsigned(y) ;} -private static bool ult64(long x, long y){ return unsigned(x) < unsigned(y) ;} - -private static sbyte lshr8(sbyte x, sbyte y){ return (sbyte) ((uint) x >> (int) y);} -private static short lshr16(short x, short y){ return (short) ((ushort) x >> (int) y);} -private static int lshr32(int x, int y){ return (int) ((uint) (x) >> (int) y);} -private static long lshr64(long x, long y){ return (long) ((ulong) x >> (int) y);} - -private static sbyte sext_i8_i8(sbyte x){return (sbyte) (x);} -private static short sext_i8_i16(sbyte x){return (short) (x);} -private static int sext_i8_i32(sbyte x){return (int) (x);} -private static long sext_i8_i64(sbyte x){return (long) (x);} - -private static sbyte sext_i16_i8(short x){return (sbyte) (x);} -private static short sext_i16_i16(short x){return (short) (x);} -private static int sext_i16_i32(short x){return (int) (x);} -private static long sext_i16_i64(short x){return (long) (x);} - -private static sbyte sext_i32_i8(int x){return (sbyte) (x);} -private static short sext_i32_i16(int x){return (short) (x);} -private static int sext_i32_i32(int x){return (int) (x);} -private static long sext_i32_i64(int x){return (long) (x);} - -private static sbyte sext_i64_i8(long x){return (sbyte) (x);} -private static short sext_i64_i16(long x){return (short) (x);} -private static int sext_i64_i32(long x){return (int) (x);} -private static long sext_i64_i64(long x){return (long) (x);} - -private static sbyte btoi_bool_i8 (bool x){return (sbyte) (Convert.ToInt32(x));} -private static short btoi_bool_i16(bool x){return (short) (Convert.ToInt32(x));} -private static int btoi_bool_i32(bool x){return (int) (Convert.ToInt32(x));} -private static long btoi_bool_i64(bool x){return (long) (Convert.ToInt32(x));} - -private static bool itob_i8_bool (sbyte x){return x != 0;} -private static bool itob_i16_bool(short x){return x != 0;} -private static bool itob_i32_bool(int x) {return x != 0;} -private static bool itob_i64_bool(long x) {return x != 0;} - -private static sbyte zext_i8_i8(sbyte x) {return (sbyte) ((byte)(x));} -private static short zext_i8_i16(sbyte x) {return (short)((byte)(x));} -private static int zext_i8_i32(sbyte x) {return (int)((byte)(x));} -private static long zext_i8_i64(sbyte x) {return (long)((byte)(x));} - -private static sbyte zext_i16_i8(short x) {return (sbyte) ((ushort)(x));} -private static short zext_i16_i16(short x) {return (short)((ushort)(x));} -private static int zext_i16_i32(short x) {return (int)((ushort)(x));} -private static long zext_i16_i64(short x) {return (long)((ushort)(x));} - -private static sbyte zext_i32_i8(int x){return (sbyte) ((uint)(x));} -private static short zext_i32_i16(int x){return (short)((uint)(x));} -private static int zext_i32_i32(int x){return (int)((uint)(x));} -private static long zext_i32_i64(int x){return (long)((uint)(x));} - -private static sbyte zext_i64_i8(long x){return (sbyte) ((ulong)(x));} -private static short zext_i64_i16(long x){return (short)((ulong)(x));} -private static int zext_i64_i32(long x){return (int)((ulong)(x));} -private static long zext_i64_i64(long x){return (long)((ulong)(x));} - -private static sbyte ssignum(sbyte x){return (sbyte) Math.Sign(x);} -private static short ssignum(short x){return (short) Math.Sign(x);} -private static int ssignum(int x){return Math.Sign(x);} -private static long ssignum(long x){return (long) Math.Sign(x);} - -private static sbyte usignum(sbyte x){return ((byte) x > 0) ? (sbyte) 1 : (sbyte) 0;} -private static short usignum(short x){return ((ushort) x > 0) ? (short) 1 : (short) 0;} -private static int usignum(int x){return ((uint) x > 0) ? (int) 1 : (int) 0;} -private static long usignum(long x){return ((ulong) x > 0) ? (long) 1 : (long) 0;} - -private static float sitofp_i8_f32(sbyte x){return Convert.ToSingle(x);} -private static float sitofp_i16_f32(short x){return Convert.ToSingle(x);} -private static float sitofp_i32_f32(int x){return Convert.ToSingle(x);} -private static float sitofp_i64_f32(long x){return Convert.ToSingle(x);} - -private static double sitofp_i8_f64(sbyte x){return Convert.ToDouble(x);} -private static double sitofp_i16_f64(short x){return Convert.ToDouble(x);} -private static double sitofp_i32_f64(int x){return Convert.ToDouble(x);} -private static double sitofp_i64_f64(long x){return Convert.ToDouble(x);} - - -private static float uitofp_i8_f32(sbyte x){return Convert.ToSingle(unsigned(x));} -private static float uitofp_i16_f32(short x){return Convert.ToSingle(unsigned(x));} -private static float uitofp_i32_f32(int x){return Convert.ToSingle(unsigned(x));} -private static float uitofp_i64_f32(long x){return Convert.ToSingle(unsigned(x));} - -private static double uitofp_i8_f64(sbyte x){return Convert.ToDouble(unsigned(x));} -private static double uitofp_i16_f64(short x){return Convert.ToDouble(unsigned(x));} -private static double uitofp_i32_f64(int x){return Convert.ToDouble(unsigned(x));} -private static double uitofp_i64_f64(long x){return Convert.ToDouble(unsigned(x));} - -private static byte fptoui_f32_i8(float x){return (byte) (Math.Truncate(x));} -private static byte fptoui_f64_i8(double x){return (byte) (Math.Truncate(x));} -private static sbyte fptosi_f32_i8(float x){return (sbyte) (Math.Truncate(x));} -private static sbyte fptosi_f64_i8(double x){return (sbyte) (Math.Truncate(x));} - -private static ushort fptoui_f32_i16(float x){return (ushort) (Math.Truncate(x));} -private static ushort fptoui_f64_i16(double x){return (ushort) (Math.Truncate(x));} -private static short fptosi_f32_i16(float x){return (short) (Math.Truncate(x));} -private static short fptosi_f64_i16(double x){return (short) (Math.Truncate(x));} - -private static uint fptoui_f32_i32(float x){return (uint) (Math.Truncate(x));} -private static uint fptoui_f64_i32(double x){return (uint) (Math.Truncate(x));} -private static int fptosi_f32_i32(float x){return (int) (Math.Truncate(x));} -private static int fptosi_f64_i32(double x){return (int) (Math.Truncate(x));} - -private static ulong fptoui_f32_i64(float x){return (ulong) (Math.Truncate(x));} -private static ulong fptoui_f64_i64(double x){return (ulong) (Math.Truncate(x));} -private static long fptosi_f32_i64(float x){return (long) (Math.Truncate(x));} -private static long fptosi_f64_i64(double x){return (long) (Math.Truncate(x));} - -private static double fpconv_f32_f64(float x){return Convert.ToDouble(x);} -private static float fpconv_f64_f32(double x){return Convert.ToSingle(x);} - -private static double futhark_log64(double x){return Math.Log(x);} -private static double futhark_log2_64(double x){return Math.Log(x,2.0);} -private static double futhark_log10_64(double x){return Math.Log10(x);} -private static double futhark_sqrt64(double x){return Math.Sqrt(x);} -private static double futhark_exp64(double x){return Math.Exp(x);} -private static double futhark_cos64(double x){return Math.Cos(x);} -private static double futhark_sin64(double x){return Math.Sin(x);} -private static double futhark_tan64(double x){return Math.Tan(x);} -private static double futhark_acos64(double x){return Math.Acos(x);} -private static double futhark_asin64(double x){return Math.Asin(x);} -private static double futhark_atan64(double x){return Math.Atan(x);} -private static double futhark_cosh64(double x){return Math.Cosh(x);} -private static double futhark_sinh64(double x){return Math.Sinh(x);} -private static double futhark_tanh64(double x){return Math.Tanh(x);} -private static double futhark_acosh64(double x){return Math.Acosh(x);} -private static double futhark_asinh64(double x){return Math.Asinh(x);} -private static double futhark_atanh64(double x){return Math.Atanh(x);} -private static double futhark_atan2_64(double x, double y){return Math.Atan2(x, y);} -private static double futhark_gamma64(double x){throw new NotImplementedException();} -private static double futhark_lgamma64(double x){throw new NotImplementedException();} -private static bool futhark_isnan64(double x){return double.IsNaN(x);} -private static bool futhark_isinf64(double x){return double.IsInfinity(x);} -private static long futhark_to_bits64(double x){return BitConverter.ToInt64(BitConverter.GetBytes(x),0);} -private static double futhark_from_bits64(long x){return BitConverter.ToDouble(BitConverter.GetBytes(x),0);} - -private static float futhark_log32(float x){return (float) Math.Log(x);} -private static float futhark_log2_32(float x){return (float) Math.Log(x,2.0);} -private static float futhark_log10_32(float x){return (float) Math.Log10(x);} -private static float futhark_sqrt32(float x){return (float) Math.Sqrt(x);} -private static float futhark_exp32(float x){return (float) Math.Exp(x);} -private static float futhark_cos32(float x){return (float) Math.Cos(x);} -private static float futhark_sin32(float x){return (float) Math.Sin(x);} -private static float futhark_tan32(float x){return (float) Math.Tan(x);} -private static float futhark_acos32(float x){return (float) Math.Acos(x);} -private static float futhark_asin32(float x){return (float) Math.Asin(x);} -private static float futhark_atan32(float x){return (float) Math.Atan(x);} -private static float futhark_cosh32(float x){return (float) Math.Cosh(x);} -private static float futhark_sinh32(float x){return (float) Math.Sinh(x);} -private static float futhark_tanh32(float x){return (float) Math.Tanh(x);} -private static float futhark_acosh32(float x){return (float) Math.Acosh(x);} -private static float futhark_asinh32(float x){return (float) Math.Asinh(x);} -private static float futhark_atanh32(float x){return (float) Math.Atanh(x);} -private static float futhark_atan2_32(float x, float y){return (float) Math.Atan2(x, y);} -private static float futhark_gamma32(float x){throw new NotImplementedException();} -private static float futhark_lgamma32(float x){throw new NotImplementedException();} -private static bool futhark_isnan32(float x){return float.IsNaN(x);} -private static bool futhark_isinf32(float x){return float.IsInfinity(x);} -private static int futhark_to_bits32(float x){return BitConverter.ToInt32(BitConverter.GetBytes(x), 0);} -private static float futhark_from_bits32(int x){return BitConverter.ToSingle(BitConverter.GetBytes(x), 0);} - -private static float futhark_round32(float x){return (float) Math.Round(x);} -private static double futhark_round64(double x){return Math.Round(x);} -private static float futhark_ceil32(float x){return (float) Math.Ceiling(x);} -private static double futhark_ceil64(double x){return Math.Ceiling(x);} -private static float futhark_floor32(float x){return (float) Math.Floor(x);} -private static double futhark_floor64(double x){return Math.Floor(x);} - -private static float futhark_lerp32(float v0, float v1, float t){return v0 + (v1-v0)*t;} -private static double futhark_lerp64(double v0, double v1, double t){return v0 + (v1-v0)*t;} - -private static float futhark_fma32(float a, float b, float c){return a*b+c;} -private static double futhark_fma64(double a, double b, double c){return a*b+c;} - -private static float futhark_mad32(float a, float b, float c){return a*b+c;} -private static double futhark_mad64(double a, double b, double c){return a*b+c;} - - -int futhark_popc8 (sbyte x) { - int c = 0; - for (; x != 0; ++c) { - x &= (sbyte)(x - 1); - } - return c; - } - -int futhark_popc16 (short x) { - int c = 0; - for (; x != 0; ++c) { - x &= (short)(x - 1); - } - return c; -} - -int futhark_popc32 (int x) { - int c = 0; - for (; x != 0; ++c) { - x &= x - 1; - } - return c; -} - -int futhark_popc64 (long x) { - int c = 0; - for (; x != 0; ++c) { - x &= x - 1; - } - return c; -} - -int futhark_clzz8 (sbyte x) { - int n = 0; - int bits = sizeof(sbyte) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; -} - -int futhark_clzz16 (short x) { - int n = 0; - int bits = sizeof(short) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; -} - -int futhark_clzz32 (int x) { - int n = 0; - int bits = sizeof(int) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; -} - -int futhark_clzz64 (long x) { - int n = 0; - int bits = sizeof(long) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; -} - -sbyte futhark_mul_hi8(sbyte a, sbyte b) { - ushort aa = (ushort)(byte)a; - ushort bb = (ushort)(byte)b; - return (sbyte)((aa * bb) >> 8); -} - -short futhark_mul_hi16(short a, short b) { - uint aa = (uint)(ushort)a; - uint bb = (uint)(ushort)b; - return (short)((aa * bb) >> 16); -} - -int futhark_mul_hi32(int a, int b) { - ulong aa = (ulong)(uint)a; - ulong bb = (ulong)(uint)b; - return (int)((aa * bb) >> 32); -} - -// By Ben Voigt at -// https://stackoverflow.com/questions/29722093/computing-the-high-bits-of-a-multiplication-in-c-sharp -long futhark_mul_hi64(long xx, long yy) { - ulong x = (ulong)xx; - ulong y = (ulong)yy; - ulong accum = ((ulong)(uint)x) * ((ulong)(uint)y); - accum >>= 32; - ulong term1 = (x >> 32) * ((ulong)(uint)y); - ulong term2 = (y >> 32) * ((ulong)(uint)x); - accum += (uint)term1; - accum += (uint)term2; - accum >>= 32; - accum += (term1 >> 32) + (term2 >> 32); - accum += (x >> 32) * (y >> 32); - return (long)accum; -} - -sbyte futhark_mad_hi8(sbyte a, sbyte b, sbyte c) { - return (sbyte)(futhark_mul_hi8(a,b) + c); -} - -short futhark_mad_hi16(short a, short b, short c) { - return (short)(futhark_mul_hi16(a,b) + c); -} - -int futhark_mad_hi32(int a, int b, int c) { - return futhark_mul_hi32(a,b) + c; -} - -long futhark_mad_hi64(long a, long b, long c) { - return futhark_mul_hi64(a,b) + c; -} - -private static bool llt (bool x, bool y){return (!x && y);} -private static bool lle (bool x, bool y){return (!x || y);} - diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -65,14 +65,11 @@ raise Exception('Program uses double-precision floats, but this is not supported on chosen device: %s' % self.device.name) def apply_size_heuristics(self, size_heuristics, sizes): - for (platform_name, device_type, size, value) in size_heuristics: + for (platform_name, device_type, size, valuef) in size_heuristics: if sizes[size] == None \ and self.platform.name.find(platform_name) >= 0 \ and self.device.type == device_type: - if type(value) == str: - sizes[size] = self.device.get_info(getattr(cl.device_info,value)) - else: - sizes[size] = value + sizes[size] = valuef(self.device) return sizes def initialise_opencl_object(self, @@ -109,7 +106,16 @@ self.max_tile_size = max_tile_size self.max_threshold = 0 self.max_num_groups = 0 + self.max_local_memory = int(self.device.local_mem_size) + + # Futhark reserves 4 bytes of local memory for its own purposes. + self.max_local_memory -= 4 + + # See comment in rts/c/opencl.h. + if self.platform.name.find('NVIDIA CUDA') >= 0: + self.max_local_memory -= 12 + self.free_list = {} self.global_failure = self.pool.allocate(np.int32().itemsize) diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -4,6 +4,16 @@ import math import struct +def intlit(t, x): + if t == np.int8: + return np.int8(x) + elif t == np.int16: + return np.int16(x) + elif t == np.int32: + return np.int32(x) + else: + return np.int64(x) + def signed(x): if type(x) == np.uint8: return np.int8(x) @@ -30,23 +40,56 @@ def ashrN(x,y): return x >> y +# Python is so slow that we just make all the unsafe operations safe, +# always. + def sdivN(x,y): - return x // y + if y == 0: + return intlit(type(x), 0) + else: + return x // y +def sdiv_upN(x,y): + if y == 0: + return intlit(type(x), 0) + else: + return (x+y-intlit(type(x), 1)) // y + def smodN(x,y): - return x % y + if y == 0: + return intlit(type(x), 0) + else: + return x % y def udivN(x,y): - return signed(unsigned(x) // unsigned(y)) + if y == 0: + return intlit(type(x), 0) + else: + return signed(unsigned(x) // unsigned(y)) +def udiv_upN(x,y): + if y == 0: + return intlit(type(x), 0) + else: + return signed((unsigned(x)+unsigned(y)-unsigned(intlit(type(x),1))) // unsigned(y)) + def umodN(x,y): - return signed(unsigned(x) % unsigned(y)) + if y == 0: + return intlit(type(x), 0) + else: + return signed(unsigned(x) % unsigned(y)) def squotN(x,y): - return np.floor_divide(np.abs(x), np.abs(y)) * np.sign(x) * np.sign(y) + if y == 0: + return intlit(type(x), 0) + else: + return np.floor_divide(np.abs(x), np.abs(y)) * np.sign(x) * np.sign(y) def sremN(x,y): - return np.remainder(np.abs(x), np.abs(y)) * np.sign(x) + if y == 0: + return intlit(type(x), 0) + else: + return np.remainder(np.abs(x), np.abs(y)) * np.sign(x) def sminN(x,y): return min(x,y) @@ -171,14 +214,25 @@ def zext_i64_i64(x): return np.int64(np.uint64(x)) -shl8 = shl16 = shl32 = shl64 = shlN -ashr8 = ashr16 = ashr32 = ashr64 = ashrN sdiv8 = sdiv16 = sdiv32 = sdiv64 = sdivN +sdiv_up8 = sdiv1_up6 = sdiv_up32 = sdiv_up64 = sdiv_upN +sdiv_safe8 = sdiv1_safe6 = sdiv_safe32 = sdiv_safe64 = sdivN +sdiv_up_safe8 = sdiv_up1_safe6 = sdiv_up_safe32 = sdiv_up_safe64 = sdiv_upN smod8 = smod16 = smod32 = smod64 = smodN +smod_safe8 = smod_safe16 = smod_safe32 = smod_safe64 = smodN udiv8 = udiv16 = udiv32 = udiv64 = udivN +udiv_up8 = udiv_up16 = udiv_up32 = udiv_up64 = udivN +udiv_safe8 = udiv_safe16 = udiv_safe32 = udiv_safe64 = udiv_upN +udiv_up_safe8 = udiv_up_safe16 = udiv_up_safe32 = udiv_up_safe64 = udiv_upN umod8 = umod16 = umod32 = umod64 = umodN +umod_safe8 = umod_safe16 = umod_safe32 = umod_safe64 = umodN squot8 = squot16 = squot32 = squot64 = squotN +squot_safe8 = squot_safe16 = squot_safe32 = squot_safe64 = squotN srem8 = srem16 = srem32 = srem64 = sremN +srem_safe8 = srem_safe16 = srem_safe32 = srem_safe64 = sremN + +shl8 = shl16 = shl32 = shl64 = shlN +ashr8 = ashr16 = ashr32 = ashr64 = ashrN smax8 = smax16 = smax32 = smax64 = smaxN smin8 = smin16 = smin32 = smin64 = sminN umax8 = umax16 = umax32 = umax64 = umaxN diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -5,7 +5,6 @@ ( printAction , impCodeGenAction , kernelImpCodeGenAction - , rangeAction , metricsAction ) where @@ -15,14 +14,12 @@ import Futhark.Pipeline import Futhark.Analysis.Alias -import Futhark.Analysis.Range import Futhark.IR import Futhark.IR.Prop.Aliases import Futhark.IR.KernelsMem (KernelsMem) import Futhark.IR.SeqMem (SeqMem) import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels -import Futhark.IR.Prop.Ranges (CanBeRanged) import Futhark.Analysis.Metrics -- | Print the result to stdout, with alias annotations. @@ -33,14 +30,6 @@ , actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis } --- | Print the result to stdout, with range annotations. -rangeAction :: (ASTLore lore, CanBeRanged (Op lore)) => Action lore -rangeAction = - Action { actionName = "Range analysis" - , actionDescription = "Print the program with range annotations added." - , actionProcedure = liftIO . putStrLn . pretty . rangeAnalysis - } - -- | Print metrics about AST node counts to stdout. metricsAction :: OpMetrics (Op lore) => Action lore metricsAction = @@ -54,7 +43,7 @@ impCodeGenAction = Action { actionName = "Compile imperative" , actionDescription = "Translate program into imperative IL and write it on standard output." - , actionProcedure = liftIO . putStrLn . pretty <=< ImpGenSequential.compileProg + , actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenSequential.compileProg } -- | Convert the program to GPU ImpCode and print it to stdout. @@ -62,5 +51,5 @@ kernelImpCodeGenAction = Action { actionName = "Compile imperative kernels" , actionDescription = "Translate program into imperative IL with kernels and write it on standard output." - , actionProcedure = liftIO . putStrLn . pretty <=< ImpGenKernels.compileProgOpenCL + , actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenKernels.compileProgOpenCL } diff --git a/src/Futhark/Analysis/AlgSimplify.hs b/src/Futhark/Analysis/AlgSimplify.hs deleted file mode 100644 --- a/src/Futhark/Analysis/AlgSimplify.hs +++ /dev/null @@ -1,1435 +0,0 @@ -{-# LANGUAGE FlexibleInstances, LambdaCase #-} --- | Algebraic simplification. Slow and limited. Use very rarely. -module Futhark.Analysis.AlgSimplify - ( ScalExp - , Error - , simplify - , mkSuffConds - , RangesRep - , ppRangesRep - , linFormScalE - , pickSymToElim - ) - where - -import qualified Data.Set as S -import qualified Data.Map.Strict as M -import Data.List (sort, sortBy, genericReplicate) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State - -import Futhark.IR hiding (SDiv, SMod, SQuot, SRem, SSignum) -import Futhark.Analysis.ScalExp -import qualified Futhark.IR.Primitive as P - --- | Ranges are inclusive. -type RangesRep = M.Map VName (Int, Maybe ScalExp, Maybe ScalExp) - --- | Prettyprint a 'RangesRep'. Do not rely on the format of this --- string. Does not include the loop nesting depth information. -ppRangesRep :: RangesRep -> String -ppRangesRep = unlines . sort . map ppRange . M.toList - where ppRange (name, (_, lower, upper)) = - pretty name ++ ": " ++ - if lower == upper - then "== " ++ ppBound lower - else "[" ++ ppBound lower ++ ", " ++ - ppBound upper ++ "]" - ppBound Nothing = "?" - ppBound (Just se) = pretty se - --- | environment recording the position and --- a list of variable-to-range bindings. -data AlgSimplifyEnv = AlgSimplifyEnv { inSolveLTH0 :: Bool - , ranges :: RangesRep - , maxSteps :: Int - -- ^ The number of - -- simplifications to do before - -- bailing out, to avoid spending - -- too much time. - } - --- | Why the algebraic simplification failed. -data Error = StepsExceeded | Error String - -type AlgSimplifyM = StateT Int (ReaderT AlgSimplifyEnv (Either Error)) - -runAlgSimplifier :: Bool -> AlgSimplifyM a -> RangesRep -> Either Error a -runAlgSimplifier s x r = runReaderT (evalStateT x 0) env - where env = AlgSimplifyEnv { inSolveLTH0 = s - , ranges = r - , maxSteps = 100 -- heuristically chosen - } - -step :: AlgSimplifyM () -step = do modify (1+) - exceeded <- gets (>) <*> asks maxSteps - when exceeded stepsExceeded - -stepsExceeded :: AlgSimplifyM a -stepsExceeded = lift $ lift $ Left StepsExceeded - -badAlgSimplifyM :: String -> AlgSimplifyM a -badAlgSimplifyM = lift . lift . Left . Error - --- | Binds an array name to the set of used-array vars -markInSolve :: AlgSimplifyEnv -> AlgSimplifyEnv -markInSolve env = - env { inSolveLTH0 = True } - -markGaussLTH0 :: AlgSimplifyM a -> AlgSimplifyM a -markGaussLTH0 = local markInSolve - ------------------------------------------------------------ --- A Scalar Expression, i.e., ScalExp, is simplified to: -- --- 1. if numeric: to a normalized sum-of-products form,-- --- in which on the outermost level there are N-ary -- --- Min/Max nodes, and the next two levels are a sum -- --- of products. -- --- 2. if boolean: to disjunctive normal form -- --- -- --- Corresponding Helper Representations are: -- --- 1. NNumExp, i.e., NSum of NProd of ScalExp -- --- 2. DNF -- ------------------------------------------------------------ - -data NNumExp = NSum [NNumExp] PrimType - | NProd [ScalExp] PrimType - deriving (Eq, Ord, Show) - -data BTerm = NRelExp RelOp0 NNumExp - | LogCt !Bool - | PosId VName - | NegId VName - deriving (Eq, Ord, Show) -type NAnd = [BTerm] -type DNF = [NAnd ] ---type NOr = [BTerm] ---type CNF = [NOr ] - --- | Applies Simplification at Expression level: -simplify :: ScalExp -> RangesRep -> ScalExp -simplify e rangesrep = case runAlgSimplifier False (simplifyScal e) rangesrep of - Left (Error err) -> - error $ "Error during algebraic simplification of: " ++ pretty e ++ - "\n" ++ err - Left StepsExceeded -> e - Right e' -> e' - --- | Given a symbol i and a scalar expression e, it decomposes --- e = a*i + b and returns (a,b) if possible, otherwise Nothing. -linFormScalE :: VName -> ScalExp -> RangesRep -> Either Error (Maybe (ScalExp,ScalExp)) -linFormScalE i e = runAlgSimplifier False (linearFormScalExp i e) - --- | Extracts sufficient conditions for a LTH0 relation to hold -mkSuffConds :: ScalExp -> RangesRep -> Either Error [[ScalExp]] -mkSuffConds e = runAlgSimplifier True (gaussElimRel e) - -{- --- | Test if Simplification engine can handle this kind of expression -canSimplify :: Int -> Either Error ScalExp --[[ScalExp]] -canSimplify i = do - let (h,_,e2) = mkRelExp i - case e2 of - (RelExp LTH0 _) -> do - -- let e1' = trace (pretty e1) e1 - simplify e2 noLoc h --- runAlgSimplifier False (gaussAllLTH0 False S.empty =<< toNumSofP =<< simplifyScal e) noLoc h - _ -> simplify e2 noLoc h-- badAlgSimplifyM "canSimplify: unimplemented!" --} -------------------------------------------------------- ---- Assumes the relational expression is simplified -- ---- All uses of gaussiam elimination from simplify -- ---- must use simplifyNRel, which calls markGaussLTH0-- ---- to set the inSolveLTH0 environment var, so that -- ---- we do not enter an infinite recurssion! -- ---- Returns True or False or the input replation,i.e.-- ---- static-only simplification! -- -------------------------------------------------------- -simplifyNRel :: BTerm -> AlgSimplifyM BTerm -simplifyNRel inp_term@(NRelExp LTH0 inp_sofp) = do - term <- cheapSimplifyNRel inp_term - in_gauss <- asks inSolveLTH0 - let tp = typeOfNAlg inp_sofp - - if in_gauss || isTrivialNRel term || tp `notElem` map IntType allIntTypes - then return term - else do ednf <- markGaussLTH0 $ gaussAllLTH0 True S.empty inp_sofp - return $ case ednf of - Val (BoolValue c) -> LogCt c - _ -> term - where - isTrivialNRel (NRelExp _ (NProd [Val _] _)) = True - isTrivialNRel NRelExp{} = False - isTrivialNRel _ = False - - cheapSimplifyNRel :: BTerm -> AlgSimplifyM BTerm - cheapSimplifyNRel (NRelExp rel (NProd [Val v] _)) = - LogCt <$> valLTHEQ0 rel v - cheapSimplifyNRel e = return e -simplifyNRel inp_term = - return inp_term --- TODO: handle more cases. - ---gaussEliminateNRel :: BTerm -> AlgSimplifyM DNF ---gaussEliminateNRel _ = --- badAlgSimplifyM "gaussElimNRel: unimplemented!" - - -gaussElimRel :: ScalExp -> AlgSimplifyM [[ScalExp]] -- ScalExp -gaussElimRel (RelExp LTH0 e) = do - e_sofp <- toNumSofP =<< simplifyScal e - e_scal<- simplifyScal =<< gaussAllLTH0 False S.empty e_sofp - e_dnf <- toDNF e_scal - mapM (mapM (\case - LogCt c -> return $ Val (BoolValue c) - PosId i -> return $ Id i $ scalExpType e - NegId i -> return $ Id i $ scalExpType e - NRelExp rel ee -> RelExp rel <$> fromNumSofP ee - )) e_dnf - -gaussElimRel _ = - badAlgSimplifyM "gaussElimRel: only LTH0 Int relations please!" - ---ppSyms :: S.Set VName -> String ---ppSyms ss = foldl (\s x -> s ++ " " ++ (baseString x)) "ElimSyms: " (S.toList ss) - - -primScalExpLTH0 :: ScalExp -> Bool -primScalExpLTH0 (Val (IntValue v)) = P.intToInt64 v < 0 -primScalExpLTH0 _ = False ------------------------------------------------------------ ------------------------------------------------------------ ------------------------------------------------------------ ----`gaussAllLTH' --- ---- `static_only':whether only a True/False answer is --- ---- required or actual a sufficient cond--- ---- `el_syms': the list of already eliminated --- ---- symbols, initialy empty --- ---- `sofp': the expression e in sum-of-product --- ---- form that is compared to 0, --- ---- i.e., e < 0. sofp assumed simplified--- ---- Result: is a ScalExp expression, which is --- ---- actually a predicate in DNF form, --- ---- that is a sufficient condition --- ---- for e < 0! --- ---- --- ---- gaussAllLTH0 is implementing the tracking of Min/Max--- ---- terms, and uses `gaussOneDefaultLTH0' --- ---- to implement gaussian-like elimination --- ---- to solve the a*i + b < 0 problem. --- ---- --- ---- IMPORTANT: before calling gaussAllLTH0 from outside --- ---- make sure to set insideSolveLTH0 env --- ---- member to True, via markGaussLTH0; --- ---- otherwise infinite recursion might happen--- ---- w.r.t. `simplifyScal' --- ------------------------------------------------------------ ------------------------------------------------------------ ------------------------------------------------------------ -type Prod = [ScalExp] -gaussAllLTH0 :: Bool -> S.Set VName -> NNumExp -> AlgSimplifyM ScalExp -gaussAllLTH0 static_only el_syms sofp = do - step - let tp = typeOfNAlg sofp - rangesrep <- asks ranges - e_scal <- fromNumSofP sofp - let mi = pickSymToElim rangesrep el_syms e_scal - - case mi of - Nothing -> return $ if primScalExpLTH0 e_scal - then Val (BoolValue True) - else RelExp LTH0 e_scal - Just i -> do - (jmm, fs0, terms) <- findMinMaxTerm i sofp - -- i.e., sofp == fs0 * jmm + terms, where - -- i appears in jmm and jmm = MinMax ... - - fs <- if not (null fs0) then return fs0 - else do one <- getPos1 tp; return [Val one] - - case jmm of - ------------------------------------------------------------------------ - -- A MinMax expression which uses to-be-eliminated symbol i was found -- - ------------------------------------------------------------------------ - Just (MaxMin _ [] ) -> - badAlgSimplifyM "gaussAllLTH0: Empty MinMax Node!" - Just (MaxMin ismin mmts) -> do - mone <- getNeg1 tp - - -- fs_lth0 => fs < 0 --- fs_lth0 <- if null fs then return $ Val (BoolValue False) --- else gaussAllLTH0 static_only el_syms (NProd fs tp) - fsm1 <- toNumSofP =<< simplifyScal =<< fromNumSofP - ( NSum [NProd fs tp, NProd [Val mone] tp] tp ) - fs_leq0 <- gaussAllLTH0 static_only el_syms fsm1 -- fs <= 0 - -- mfsm1 = - fs - 1, fs_geq0 => (fs >= 0), - -- i.e., fs_geq0 => (-fs - 1 < 0) - mfsm1 <- toNumSofP =<< simplifyScal =<< fromNumSofP - ( NSum [NProd (Val mone:fs) tp,NProd [Val mone] tp] tp ) - fs_geq0 <- gaussAllLTH0 static_only el_syms mfsm1 - - -- mm_terms are the simplified terms of the MinMax obtained - -- after inlining everything inside the MinMax, i.e., intially - -- terms + fs * MinMax ismin [t1,..,tn] -> [fs*t1+terms, ..., fs*tn+terms] - mm_terms<- mapM (\t -> toNumSofP =<< simplifyScal =<< fromNumSofP - (NSum ( NProd (t:fs) tp:terms ) tp) ) mmts - - -- for every (simplified) `term_i' of the inline MinMax exp, - -- get the sufficient conditions for `term_i < 0' - mms <- mapM (gaussAllLTH0 static_only el_syms) mm_terms - - if static_only - -------------------------------------------------------------------- - -- returns either Val (BoolValue True) or the original ScalExp relat -- - -------------------------------------------------------------------- - then if ( fs_geq0 == Val (BoolValue True) && ismin) || - ( fs_leq0 == Val (BoolValue True) && not ismin) - -- at least one term should be < 0! - then do let is_one_true = Val (BoolValue True ) `elem` mms - let are_all_false = all (== Val (BoolValue False)) mms - return $ if is_one_true then Val (BoolValue True) - else if are_all_false then Val (BoolValue False) - else RelExp LTH0 e_scal - -- otherwise all terms should be all true! - else do let are_all_true = all (== Val (BoolValue True )) mms - let is_one_false = Val (BoolValue False) `elem` mms - return $ if are_all_true then Val (BoolValue True ) - else if is_one_false then Val (BoolValue False) - else RelExp LTH0 e_scal - -------------------------------------------------------------------- - -- returns sufficient conditions for the ScalExp relation to hold -- - -------------------------------------------------------------------- - else do - let mm_fsgeq0 = foldl (if ismin then SLogOr else SLogAnd) - (Val (BoolValue (not ismin))) mms - let mm_fslth0 = foldl (if ismin then SLogAnd else SLogOr) - (Val (BoolValue ismin )) mms - -- the sufficient condition for the original expression, e.g., - -- terms + fs * Min [t1,..,tn] < 0 is - -- (fs >= 0 && (fs*t_1+terms < 0 || ... || fs*t_n+terms < 0) ) || - -- (fs < 0 && (fs*t_1+terms < 0 && ... && fs*t_n+terms < 0) ) - return $ SLogOr (SLogAnd fs_geq0 mm_fsgeq0) (SLogAnd fs_leq0 mm_fslth0) - - Just _ -> badAlgSimplifyM "gaussOneLTH0: (Just MinMax) invariant violated!" - ------------------------------------------------------------------------ - -- A MinMax expression which uses (to-be-elim) symbol i was NOT found -- - ------------------------------------------------------------------------ - Nothing-> do - m_sofp <- gaussOneDefaultLTH0 static_only i el_syms sofp - case m_sofp of - Nothing -> gaussAllLTH0 static_only (S.insert i el_syms) sofp - Just res_eofp -> return res_eofp - where - findMinMaxTerm :: VName -> NNumExp -> AlgSimplifyM (Maybe ScalExp, Prod, [NNumExp]) - findMinMaxTerm _ (NSum [] _) = return (Nothing, [], []) - findMinMaxTerm _ (NSum [NProd [MaxMin ismin e] _] _) = - return (Just (MaxMin ismin e), [], []) - findMinMaxTerm _ (NProd [MaxMin ismin e] _) = - return (Just (MaxMin ismin e), [], []) - - findMinMaxTerm ii t@NProd{} = do (mm, fs) <- findMinMaxFact ii t - return (mm, fs, []) - findMinMaxTerm ii (NSum (t:ts) tp)= do - rangesrep <- asks ranges - case M.lookup ii rangesrep of - Just (_, Just _, Just _) -> do - f <- findMinMaxFact ii t - case f of - (Just mm, fs) -> return (Just mm, fs, ts) - (Nothing, _ ) -> do (mm, fs', ts') <- findMinMaxTerm ii (NSum ts tp) - return (mm, fs', t:ts') - _ -> return (Nothing, [], t:ts) - - findMinMaxFact :: VName -> NNumExp -> AlgSimplifyM (Maybe ScalExp, Prod) - findMinMaxFact _ (NProd [] _ ) = return (Nothing, []) - findMinMaxFact ii (NProd (f:fs) tp) = - case f of - MaxMin ismin ts -> do - let id_set = mconcat $ map freeIn ts - if ii `nameIn` id_set - then return (Just (MaxMin ismin ts), fs) - else do (mm, fs') <- findMinMaxFact ii (NProd fs tp) - return (mm, f:fs') - - _ -> do (mm, fs') <- findMinMaxFact ii (NProd fs tp) - return (mm, f:fs') - findMinMaxFact ii (NSum [f] _) = findMinMaxFact ii f - findMinMaxFact _ (NSum _ _) = - badAlgSimplifyM "findMinMaxFact: NSum argument illegal!" - - - -gaussOneDefaultLTH0 :: Bool -> VName -> S.Set VName -> NNumExp -> AlgSimplifyM (Maybe ScalExp) -gaussOneDefaultLTH0 static_only i elsyms e = do - aipb <- linearForm i e - case aipb of - Nothing -> return Nothing - Just (a, b) -> do - rangesrep <- asks ranges - one <- getPos1 (typeOfNAlg e) - ascal <- fromNumSofP a - mam1 <- toNumSofP =<< simplifyScal (SNeg (SPlus ascal (Val one))) - am1 <- toNumSofP =<< simplifyScal (SMinus ascal (Val one)) - ma <- toNumSofP =<< simplifyScal (SNeg ascal) - - b_scal<- fromNumSofP b - mbm1 <- toNumSofP =<< simplifyScal (SNeg (SPlus b_scal (Val one))) - - aleq0 <- simplifyScal =<< gaussAllLTH0 static_only elsyms am1 - ageq0 <- simplifyScal =<< gaussAllLTH0 static_only elsyms mam1 - - case M.lookup i rangesrep of - Nothing -> - badAlgSimplifyM "gaussOneDefaultLTH0: sym not in ranges!" - Just (_, Nothing, Nothing) -> - badAlgSimplifyM "gaussOneDefaultLTH0: both bounds are undefined!" - - -- only the lower-bound of i is known! - Just (_, Just lb, Nothing) -> do - alpblth0 <- gaussElimHalf static_only elsyms lb a b - and_half <- simplifyScal alpblth0 - case (and_half, aleq0) of - (Val (BoolValue True), Val (BoolValue True)) -> - return $ Just and_half - _ -> do malmbm1lth0 <- gaussElimHalf static_only elsyms lb ma mbm1 - other_half <- simplifyScal malmbm1lth0 - case (other_half, ageq0) of - (Val (BoolValue True), Val (BoolValue True)) -> - return $ Just (Val (BoolValue False)) - _ -> return Nothing - - Just (_, Nothing, Just ub) -> do - aupblth0 <- gaussElimHalf static_only elsyms ub a b - and_half <- simplifyScal aupblth0 - case (and_half, ageq0) of - (Val (BoolValue True), Val (BoolValue True)) -> - return $ Just and_half - _ -> do - maumbm1 <- gaussElimHalf static_only elsyms ub ma mbm1 - other_half <- simplifyScal maumbm1 - case (other_half, aleq0) of - (Val (BoolValue True), Val (BoolValue True)) -> - return $ Just (Val (BoolValue False)) - _ -> return Nothing - - Just (_, Just lb, Just ub) -> - if static_only - then if aleq0 == Val (BoolValue True) - then do alpblth0 <- simplifyScal =<< gaussElimHalf static_only elsyms lb a b - if alpblth0 == Val (BoolValue True) - then return $ Just (Val (BoolValue True)) - else do maubmbm1 <- simplifyScal =<< gaussElimHalf static_only elsyms ub ma mbm1 - return $ if maubmbm1 == Val (BoolValue True) - then Just (Val (BoolValue False)) - else Nothing - else if ageq0 == Val (BoolValue True) - then do aupblth0 <- simplifyScal =<< gaussElimHalf static_only elsyms ub a b - if aupblth0 == Val (BoolValue True) - then return $ Just (Val (BoolValue True)) - else do malbmbm1 <- simplifyScal =<< gaussElimHalf static_only elsyms lb ma mbm1 - return $ if malbmbm1 == Val (BoolValue True) - then Just (Val (BoolValue False)) - else Nothing - else return Nothing - else do - alpblth0 <- gaussElimHalf static_only elsyms lb a b - aupblth0 <- gaussElimHalf static_only elsyms ub a b - res <- simplifyScal $ SLogOr (SLogAnd aleq0 alpblth0) (SLogAnd ageq0 aupblth0) - return $ Just res - - where - gaussElimHalf :: Bool -> S.Set VName -> ScalExp -> NNumExp -> NNumExp -> AlgSimplifyM ScalExp - gaussElimHalf only_static elsyms0 q a b = do - a_scal <- fromNumSofP a - b_scal <- fromNumSofP b - e_num_scal <- simplifyScal (SPlus (STimes a_scal q) b_scal) - e_num <- toNumSofP e_num_scal - gaussAllLTH0 only_static elsyms0 e_num - --- | Pick a Symbol to Eliminate & Bring To Linear Form -pickSymToElim :: RangesRep -> S.Set VName -> ScalExp -> Maybe VName -pickSymToElim rangesrep elsyms0 e_scal = - let ids0= namesToList $ freeIn e_scal - ids1= filter (\s -> not (S.member s elsyms0)) ids0 - ids2= filter (\s -> case M.lookup s rangesrep of - Nothing -> False - Just _ -> True - ) ids1 - ids = sortBy (\n1 n2 -> let n1p = M.lookup n1 rangesrep - n2p = M.lookup n2 rangesrep - in case (n1p, n2p) of - (Just (p1,_,_), Just (p2,_,_)) -> compare (-p1) (-p2) - (_ , _ ) -> compare (1::Int) (1::Int) - ) ids2 - in case ids of - [] -> Nothing - v:_ -> Just v - - -linearFormScalExp :: VName -> ScalExp -> AlgSimplifyM (Maybe (ScalExp, ScalExp)) -linearFormScalExp sym scl_exp = do - sofp <- toNumSofP =<< simplifyScal scl_exp - ab <- linearForm sym sofp - case ab of - Just (a_sofp, b_sofp) -> do - a <- fromNumSofP a_sofp - b <- fromNumSofP b_sofp - a'<- simplifyScal a - b'<- simplifyScal b - return $ Just (a', b') - Nothing -> - return Nothing - -linearForm :: VName -> NNumExp -> AlgSimplifyM (Maybe (NNumExp, NNumExp)) -linearForm _ (NProd [] _) = - badAlgSimplifyM "linearForm: empty Prod!" -linearForm idd ee@NProd{} = linearForm idd (NSum [ee] (typeOfNAlg ee)) -linearForm _ (NSum [] _) = - badAlgSimplifyM "linearForm: empty Sum!" -linearForm idd (NSum terms tp) = do - terms_d_idd <- mapM (\t -> do t0 <- case t of - NProd (_:_) _ -> return t - _ -> badAlgSimplifyM "linearForm: ILLEGAL111!!!!" - t_scal <- fromNumSofP t0 - simplifyScal $ SDiv t_scal (Id idd (scalExpType t_scal)) - ) terms - let myiota = [1..(length terms)] - let ia_terms= filter (\(_,t)-> case t of - SDiv _ _ -> False - _ -> True - ) (zip myiota terms_d_idd) - let (a_inds, a_terms) = unzip ia_terms - - let (_, b_terms) = unzip $ filter (\(iii,_) -> iii `notElem` a_inds) - (zip myiota terms) - -- check that b_terms do not contain idd - b_succ <- foldM (\acc x -> - case x of - NProd fs _ -> do let fs_scal = case fs of - [] -> Val $ IntValue $ Int32Value 1 - f:fs' -> foldl STimes f fs' - let b_ids = freeIn fs_scal - return $ acc && not (idd `nameIn` b_ids) - _ -> badAlgSimplifyM "linearForm: ILLEGAL222!!!!" - ) True b_terms - - case a_terms of - t:ts | b_succ -> do - let a_scal = foldl SPlus t ts - a_terms_sofp <- toNumSofP =<< simplifyScal a_scal - b_terms_sofp <- if null b_terms - then do zero <- getZero tp; return $ NProd [Val zero] tp - else return $ NSum b_terms tp - return $ Just (a_terms_sofp, b_terms_sofp) - _ -> return Nothing - ------------------------------------------------- ------------------------------------------------- --- Main Helper Function: takes a scalar exp, -- --- normalizes and simplifies it -- ------------------------------------------------- ------------------------------------------------- - -simplifyScal :: ScalExp -> AlgSimplifyM ScalExp - -simplifyScal (Val v) = return $ Val v -simplifyScal (Id x t) = return $ Id x t - -simplifyScal e@SNot{} = fromDNF =<< simplifyDNF =<< toDNF e -simplifyScal e@SLogAnd{} = fromDNF =<< simplifyDNF =<< toDNF e -simplifyScal e@SLogOr{} = fromDNF =<< simplifyDNF =<< toDNF e -simplifyScal e@RelExp{} = fromDNF =<< simplifyDNF =<< toDNF e - --------------------------------------- ---- MaxMin related simplifications --- --------------------------------------- -simplifyScal (MaxMin _ []) = - badAlgSimplifyM "Scalar MaxMin expression with empty arglist." -simplifyScal (MaxMin _ [e]) = simplifyScal e -simplifyScal (MaxMin ismin es) = do -- helperMinMax ismin es pos - -- pos <- asks pos - es0 <- mapM simplifyScal es - let evals = filter isValue es0 - es' = filter (not . isValue) es0 - mvv = case evals of - [] -> Nothing - v:vs -> let myop = if ismin then min else max - myval= getValue v - oneval = (foldl myop myval . map getValue) vs - in Just $ Val oneval - -- flatten the result and remove duplicates, - -- e.g., Max(Max(e1,e2), e1) -> Max(e1,e2,e3) - case (es', mvv) of - ([], Just vv) -> return vv - (_, Just vv) -> return $ MaxMin ismin $ remDups $ foldl flatop [] $ vv:es' - (_, Nothing) -> return $ MaxMin ismin $ remDups $ foldl flatop [] es' - -- ToDo: This can prove very expensive as compile time - -- but, IF e2-e1 <= 0 simplifies to True THEN - -- Min(e1,e2) = e2. Code example: - -- e1me2 <- if isMin - -- then simplifyScal $ AlgOp MINUS e1 e2 pos - -- else simplifyScal $ AlgOp MINUS e2 e1 pos - -- e1me2leq0 <- simplifyNRel $ NRelExp LEQ0 e1me2 pos - -- case e1me2leq0 of - -- NAnd [LogCt True _] _ -> simplifyAlgN e1 - -- NAnd [LogCt False _] _ -> simplifyAlgN e2 - where - isValue :: ScalExp -> Bool - isValue e = case e of - Val _ -> True - _ -> False - getValue :: ScalExp -> PrimValue - getValue se = case se of - Val v -> v - _ -> value (0::Int32) - flatop :: [ScalExp] -> ScalExp -> [ScalExp] - flatop a e@(MaxMin ismin' ses) = - a ++ if ismin == ismin' then ses else [e] - flatop a e = a++[e] - remDups :: [ScalExp] -> [ScalExp] - remDups l = S.toList (S.fromList l) - ---------------------------------------------------- ---- Plus/Minus related simplifications --- ---- BUG: the MinMax pattern matching should --- ---- be performed on the simplified subexps --- ---------------------------------------------------- -simplifyScal (SPlus e1o e2o) = do - e1' <- simplifyScal e1o - e2' <- simplifyScal e2o - if isMaxMin e1' || isMaxMin e2' - then helperPlusMinMax $ SPlus e1' e2' - else normalPlus e1' e2' - - where - normalPlus :: ScalExp -> ScalExp -> AlgSimplifyM ScalExp - normalPlus e1 e2 = do - e1' <- toNumSofP e1 - e2' <- toNumSofP e2 - let tp = scalExpType e1 - let terms = getTerms e1' ++ getTerms e2' - splittedTerms <- mapM splitTerm terms - let sortedTerms = sortBy (\(n1,_) (n2,_) -> compare n1 n2) splittedTerms - -- foldM discriminate: adds together identical terms, and - -- we reverse the list, to keep it in a ascending order. - merged <- reverse <$> foldM discriminate [] sortedTerms - let filtered = filter (\(_,v) -> not $ zeroIsh v ) merged - if null filtered - then do - zero <- getZero tp - fromNumSofP $ NProd [Val zero] tp - else do - terms' <- mapM joinTerm filtered - fromNumSofP $ NSum terms' tp - -simplifyScal (SMinus e1 e2) = do - let tp = scalExpType e1 - if e1 == e2 - then Val <$> getZero tp - else do min_1 <- getNeg1 $ scalExpType e1 - simplifyScal $ SPlus e1 $ STimes (Val min_1) e2 - -simplifyScal (SNeg e) = do - negOne <- getNeg1 $ scalExpType e - simplifyScal $ STimes (Val negOne) e - -simplifyScal (SAbs e) = return $ SAbs e - -simplifyScal (SSignum e) = return $ SSignum e - ---------------------------------------------------- ---- Times related simplifications --- ---- BUG: the MinMax pattern matching should --- ---- be performed on the simplified subexps --- ---------------------------------------------------- -simplifyScal (STimes e1o e2o) = do - e1'' <- simplifyScal e1o - e2'' <- simplifyScal e2o - if isMaxMin e1'' || isMaxMin e2'' - then helperMultMinMax $ STimes e1'' e2'' - else normalTimes e1'' e2'' - - where - normalTimes :: ScalExp -> ScalExp -> AlgSimplifyM ScalExp - normalTimes e1 e2 = do - let tp = scalExpType e1 - e1' <- toNumSofP e1 - e2' <- toNumSofP e2 - case (e1', e2') of - (NProd xs _, y@NProd{}) -> fromNumSofP =<< makeProds xs y - (NProd xs _, y) -> do - prods <- mapM (makeProds xs) $ getTerms y - fromNumSofP $ NSum (sort prods) tp - (x, NProd ys _) -> do - prods <- mapM (makeProds ys) $ getTerms x - fromNumSofP $ NSum (sort prods) tp - (NSum xs _, NSum ys _) -> do - xsMultChildren <- mapM getMultChildren xs - prods <- mapM (\x -> mapM (makeProds x) ys) xsMultChildren - fromNumSofP $ NSum (sort $ concat prods) tp - - makeProds :: [ScalExp] -> NNumExp -> AlgSimplifyM NNumExp - makeProds [] _ = - badAlgSimplifyM " In simplifyAlgN, makeProds: 1st arg is the empty list! " - makeProds _ (NProd [] _) = - badAlgSimplifyM " In simplifyAlgN, makeProds: 2nd arg is the empty list! " - makeProds _ NSum{} = - badAlgSimplifyM " In simplifyAlgN, makeProds: e1 * e2: e2 is a sum of sums! " - makeProds (Val v1:exs) (NProd (Val v2:ys) tp1) = do - v <- mulVals v1 v2 - return $ NProd (Val v : sort (ys++exs) ) tp1 - makeProds (Val v:exs) (NProd ys tp1) = - return $ NProd (Val v : sort (ys++exs) ) tp1 - makeProds exs (NProd (Val v : ys) tp1) = - return $ NProd (Val v : sort (ys++exs) ) tp1 - makeProds exs (NProd ys tp1) = - return $ NProd (sort (ys++exs)) tp1 - ---------------------------------------------------- ---------------------------------------------------- ---- DIvide related simplifications --- ---------------------------------------------------- ---------------------------------------------------- - -simplifyScal (SDiv e1o e2o) = do - e1' <- simplifyScal e1o - e2' <- simplifyScal e2o - - if isMaxMin e1' || isMaxMin e2' - then helperMultMinMax $ SDiv e1' e2' - else normalFloatDiv e1' e2' - - where - normalFloatDiv :: ScalExp -> ScalExp -> AlgSimplifyM ScalExp - normalFloatDiv e1 e2 - | e1 == e2 = do one <- getPos1 $ scalExpType e1 - return $ Val one --- | e1 == (negateSimplified e2) = do mone<- getNeg1 $ scalExpType e1 --- return $ Val mone - | otherwise = do - e1' <- toNumSofP e1 - e2' <- toNumSofP e2 - case e2' of - NProd fs tp -> do - e1Split <- mapM splitTerm (getTerms e1') - case e1Split of - [] -> Val <$> getZero tp - _ -> do (fs', e1Split') <- trySimplifyDivRec fs [] e1Split - if length fs' == length fs - then turnBackAndDiv e1' e2' -- insuccess - else do terms_e1' <- mapM joinTerm e1Split' - e1'' <- fromNumSofP $ NSum terms_e1' tp - case fs' of - [] -> return e1'' - _ -> do e2'' <- fromNumSofP $ NProd fs' tp - return $ SDiv e1'' e2'' - - _ -> turnBackAndDiv e1' e2' - - turnBackAndDiv :: NNumExp -> NNumExp -> AlgSimplifyM ScalExp - turnBackAndDiv ee1 ee2 = do - ee1' <- fromNumSofP ee1 - ee2' <- fromNumSofP ee2 - return $ SDiv ee1' ee2' - -simplifyScal (SMod e1o e2o) = - SMod <$> simplifyScal e1o <*> simplifyScal e2o - -simplifyScal (SQuot e1o e2o) = - SQuot <$> simplifyScal e1o <*> simplifyScal e2o - -simplifyScal (SRem e1o e2o) = - SRem <$> simplifyScal e1o <*> simplifyScal e2o - ---------------------------------------------------- ---------------------------------------------------- ---- Power related simplifications --- ---------------------------------------------------- ---------------------------------------------------- - --- cannot handle 0^a, because if a < 0 then it's an error. --- Could be extented to handle negative exponents better, if needed -simplifyScal (SPow e1 e2) = do - let tp = scalExpType e1 - e1' <- simplifyScal e1 - e2' <- simplifyScal e2 - - if isCt1 e1' || isCt0 e2' - then Val <$> getPos1 tp - else if isCt1 e2' - then return e1' - else case (e1', e2') of - (Val v1, Val v2) - | Just v <- powVals v1 v2 -> return $ Val v - (_, Val (IntValue n)) -> - if P.intToInt64 n >= 1 - then -- simplifyScal =<< fromNumSofP $ NProd (replicate n e1') tp - do new_e <- fromNumSofP $ NProd (genericReplicate (P.intToInt64 n) e1') tp - simplifyScal new_e - else return $ SPow e1' e2' - (_, _) -> return $ SPow e1' e2' - - where - powVals :: PrimValue -> PrimValue -> Maybe PrimValue - powVals (IntValue v1) (IntValue v2) = IntValue <$> P.doPow v1 v2 - powVals _ _ = Nothing - ------------------------------------------------------ ---- Helpers for simplifyScal: MinMax related, etc --- ------------------------------------------------------ - -isMaxMin :: ScalExp -> Bool -isMaxMin MaxMin{} = True -isMaxMin _ = False - -helperPlusMinMax :: ScalExp -> AlgSimplifyM ScalExp -helperPlusMinMax (SPlus (MaxMin ismin es) e) = - simplifyScal $ MaxMin ismin $ map (`SPlus` e) es -helperPlusMinMax (SPlus e (MaxMin ismin es)) = - simplifyScal $ MaxMin ismin $ map (SPlus e) es -helperPlusMinMax _ = badAlgSimplifyM "helperPlusMinMax: Reached unreachable case!" - -{- -helperMinusMinMax :: ScalExp -> AlgSimplifyM ScalExp -helperMinusMinMax (SMinus (MaxMin ismin es) e) = - simplifyScal $ MaxMin ismin $ map (\x -> SMinus x e) es -helperMinusMinMax (SMinus e (MaxMin ismin es)) = - simplifyScal $ MaxMin ismin $ map (\x -> SMinus e x) es -helperMinusMinMax _ = do - pos <- asks pos - badAlgSimplifyM "helperMinusMinMax: Reached unreachable case!" --} -helperMultMinMax :: ScalExp -> AlgSimplifyM ScalExp -helperMultMinMax (STimes e em@MaxMin{}) = helperTimesDivMinMax True True em e -helperMultMinMax (STimes em@MaxMin{} e) = helperTimesDivMinMax True False em e -helperMultMinMax (SDiv e em@MaxMin{}) = helperTimesDivMinMax False True em e -helperMultMinMax (SDiv em@MaxMin{} e) = helperTimesDivMinMax False False em e -helperMultMinMax _ = badAlgSimplifyM "helperMultMinMax: Reached unreachable case!" - -helperTimesDivMinMax :: Bool -> Bool -> ScalExp -> ScalExp -> AlgSimplifyM ScalExp -helperTimesDivMinMax isTimes isRev emo@MaxMin{} e = do - em <- simplifyScal emo - case em of - MaxMin ismin es -> do - e' <- simplifyScal e - e'_sop <- toNumSofP e' - p' <- simplifyNRel $ NRelExp LTH0 e'_sop - case p' of - LogCt ctbool -> do --- let cond = not isTimes && isRev --- let cond'= if ctbool then cond else not cond --- let ismin'= if cond' then ismin else not ismin - - let cond = ( isTimes && not ctbool ) || - ( not isTimes && not isRev && not ctbool ) || - ( not isTimes && isRev && ctbool ) - let ismin' = if cond then ismin else not ismin - simplifyScal $ MaxMin ismin' $ map (`mkTimesDiv` e') es - - _ -> if not isTimes then return $ mkTimesDiv em e' - else -- e' * MaxMin{...} - case e'_sop of - NProd _ _ -> return $ mkTimesDiv em e' -- simplifyScal =<< fromNumSofP (NProd (em:fs) tp) - NSum ts tp -> do - new_ts <- - mapM (\case - NProd fs _ -> return $ NProd (em:fs) tp - _ -> badAlgSimplifyM - "helperTimesDivMinMax: SofP invariant violated!" - ) ts - simplifyScal =<< fromNumSofP ( NSum new_ts tp ) - _ -> simplifyScal $ mkTimesDiv em e - where - mkTimesDiv :: ScalExp -> ScalExp -> ScalExp - mkTimesDiv e1 e2 - | not isTimes = if isRev then SDiv e2 e1 else SDiv e1 e2 - | isRev = STimes e2 e1 - | otherwise = STimes e1 e2 - -helperTimesDivMinMax _ _ _ _ = - badAlgSimplifyM "helperTimesDivMinMax: Reached unreachable case!" - - ---------------------------------------------------- ---------------------------------------------------- ---- translating to and simplifying the --- ---- disjunctive normal form: toDNF, simplifyDNF --- ---------------------------------------------------- ---------------------------------------------------- ---isTrueDNF :: DNF -> Bool ---isTrueDNF [[LogCt True]] = True ---isTrueDNF _ = False --- ---getValueDNF :: DNF -> Maybe Bool ---getValueDNF [[LogCt True]] = Just True ---getValueDNF [[LogCt False]] = Just True ---getValueDNF _ = Nothing - - -negateBTerm :: BTerm -> AlgSimplifyM BTerm -negateBTerm (LogCt v) = return $ LogCt (not v) -negateBTerm (PosId i) = return $ NegId i -negateBTerm (NegId i) = return $ PosId i -negateBTerm (NRelExp rel e) = do - let tp = typeOfNAlg e - case (tp, rel) of - (IntType it, LTH0) -> do - se <- fromNumSofP e - ne <- toNumSofP =<< simplifyScal (SNeg $ SPlus se (Val (value (P.intValue it (1::Int))))) - return $ NRelExp LTH0 ne - _ -> NRelExp (if rel == LEQ0 then LTH0 else LEQ0) <$> - (toNumSofP =<< negateSimplified =<< fromNumSofP e) - -bterm2ScalExp :: BTerm -> AlgSimplifyM ScalExp -bterm2ScalExp (LogCt v) = return $ Val $ BoolValue v -bterm2ScalExp (PosId i) = return $ Id i int32 -bterm2ScalExp (NegId i) = return $ SNot $ Id i int32 -bterm2ScalExp (NRelExp rel e) = RelExp rel <$> fromNumSofP e - --- translates from DNF to ScalExp -fromDNF :: DNF -> AlgSimplifyM ScalExp -fromDNF [] = badAlgSimplifyM "fromDNF: empty DNF!" -fromDNF (t:ts) = do - t' <- translFact t - foldM (\acc x -> do x' <- translFact x; return $ SLogOr x' acc) t' ts - where - translFact [] = badAlgSimplifyM "fromDNF, translFact empty DNF factor!" - translFact (f:fs) = do - f' <- bterm2ScalExp f - foldM (\acc x -> do x' <- bterm2ScalExp x; return $ SLogAnd x' acc) f' fs - --- translates (and simplifies numeric expressions?) to DNF form. -toDNF :: ScalExp -> AlgSimplifyM DNF -toDNF (Val (BoolValue v)) = return [[LogCt v]] -toDNF (Id idd _ ) = return [[PosId idd]] -toDNF (RelExp rel e ) = do - let t = scalExpType e - case t of - IntType it -> do - e' <- if rel == LEQ0 - then do m1 <- getNeg1 $ IntType it - return $ SPlus e $ Val m1 - else return e - ne <- toNumSofP =<< simplifyScal e' - nrel <- simplifyNRel $ NRelExp LTH0 ne -- False - return [[nrel]] - - _ -> do ne <- toNumSofP =<< simplifyScal e - nrel <- markGaussLTH0 $ simplifyNRel $ NRelExp rel ne - return [[nrel]] --- -toDNF (SNot (SNot e)) = toDNF e -toDNF (SNot (Val (BoolValue v))) = return [[LogCt $ not v]] -toDNF (SNot (Id idd _)) = return [[NegId idd]] -toDNF (SNot (RelExp rel e)) = do - let not_rel = if rel == LEQ0 then LTH0 else LEQ0 - neg_e <- simplifyScal (SNeg e) - toDNF $ RelExp not_rel neg_e --- -toDNF (SLogOr e1 e2 ) = do - e1s <- toDNF e1 - e2s <- toDNF e2 - return $ sort $ e1s ++ e2s -toDNF (SLogAnd e1 e2 ) = do - -- [t1 ++ t2 | t1 <- toDNF e1, t2 <- toDNF e2] - e1s <- toDNF e1 - e2s <- toDNF e2 - let lll = map (\t2-> map (++t2) e1s) e2s - return $ sort $ concat lll -toDNF (SNot (SLogAnd e1 e2)) = do - e1s <- toDNF (SNot e1) - e2s <- toDNF (SNot e2) - return $ sort $ e1s ++ e2s -toDNF (SNot (SLogOr e1 e2)) = do - -- [t1 ++ t2 | t1 <- dnf $ SNot e1, t2 <- dnf $ SNot e2] - e1s <- toDNF $ SNot e1 - e2s <- toDNF $ SNot e2 - let lll = map (\t2-> map (++t2) e1s) e2s - return $ sort $ concat lll -toDNF _ = badAlgSimplifyM "toDNF: not a boolean expression!" - ------------------------------------------------------- ---- Simplifying Boolean Expressions: --- ---- 0. p AND p == p; p OR p == p --- ---- 1. False AND p == False; True OR p == True --- ---- 2. True AND p == p; False OR p == p --- ---- 3.(not p)AND p == FALSE; (not p)OR p == True --- ---- 4. ToDo: p1 AND p2 == p1 if p1 => p2 --- ---- p1 AND p2 == False if p1 => not p2 or--- ---- p2 => not p1 --- ---- Also: p1 OR p2 == p2 if p1 => p2 --- ---- p1 OR p2 == True if not p1 => p2 or --- ---- not p2 => p1 --- ---- This boils down to relations: --- ---- e1 < 0 => e2 < 0 if e2 <= e1 --- ------------------------------------------------------- -simplifyDNF :: DNF -> AlgSimplifyM DNF -simplifyDNF terms0 = do - terms1 <- mapM (simplifyAndOr True) terms0 - let terms' = if [LogCt True] `elem` terms1 then [[LogCt True]] - else S.toList $ S.fromList $ - filter (/= [LogCt False]) terms1 - if null terms' then return [[LogCt False]] - else do - let len1terms = all ((1==) . length) terms' - if not len1terms then return terms' - else do let terms_flat = concat terms' - terms'' <- simplifyAndOr False terms_flat - return $ map (:[]) terms'' - --- big helper function for simplifyDNF -simplifyAndOr :: Bool -> [BTerm] -> AlgSimplifyM [BTerm] -simplifyAndOr _ [] = badAlgSimplifyM "simplifyAndOr: not a boolean expression!" -simplifyAndOr is_and fs = - if LogCt (not is_and) `elem` fs - -- False AND p == False - then return [LogCt $ not is_and] - -- (i) p AND p == p, (ii) True AND p == p - else do let fs' = S.toList . S.fromList . filter (/=LogCt is_and) $ fs - if null fs' - then return [LogCt is_and] - else do -- IF p1 => p2 THEN p1 AND p2 --> p1 - fs''<- foldM (\l x-> do (addx, l') <- trimImplies is_and x l - return $ if addx then x:l' else l' - ) [] fs' - -- IF p1 => not p2 THEN p1 AND p2 == False - isF <- foldM (\b x -> if b then return b - else do notx <- negateBTerm x - impliesAny is_and x notx fs'' - ) False fs'' - return $ if not isF then fs'' - else if is_and then [LogCt False] - else [LogCt True ] - where - -- e1 => e2 ? - impliesRel :: BTerm -> BTerm -> AlgSimplifyM Bool - impliesRel (LogCt False) _ = return True - impliesRel _ (LogCt True) = return True - impliesRel (LogCt True) e = do - let e' = e -- simplifyNRel e - return $ e' == LogCt True - impliesRel e (LogCt False) = do - e' <- negateBTerm e -- simplifyNRel =<< negateBTerm e - return $ e' == LogCt True - impliesRel (NRelExp rel1 e1) (NRelExp rel2 e2) = do - -- ToDo: implement implies relation! - --not_aggr <- asks cheap - let btp = typeOfNAlg e1 - if btp /= typeOfNAlg e2 - then return False - else do - one <- getPos1 btp - e1' <- fromNumSofP e1 - e2' <- fromNumSofP e2 - case (rel1, rel2, btp) of - (LTH0, LTH0, IntType _) -> do - e2me1m1 <- toNumSofP =<< simplifyScal (SMinus e2' $ SPlus e1' $ Val one) - diffrel <- simplifyNRel $ NRelExp LTH0 e2me1m1 - return $ diffrel == LogCt True - (_, _, IntType _) -> badAlgSimplifyM "impliesRel: LEQ0 for Int!" - (_, _, _) -> badAlgSimplifyM "impliesRel: exp of illegal type!" - impliesRel p1 p2 - | p1 == p2 = return True - | otherwise = return False - - -- trimImplies(true, x, l) performs: p1 AND p2 == p1 if p1 => p2, - -- i.e., removes any p in l such that: - -- (i) x => p orelse if - -- (ii) p => x then indicates that p should not be added to the reuslt - -- trimImplies(false, x, l) performs: p1 OR p2 == p2 if p1 => p2, - -- i.e., removes any p from l such that: - -- (i) p => x orelse if - -- (ii) x => p then indicates that p should not be added to the result - trimImplies :: Bool -> BTerm -> [BTerm] -> AlgSimplifyM (Bool, [BTerm]) - trimImplies _ _ [] = return (True, []) - trimImplies and_case x (p:ps) = do - succc <- impliesRel x p - if succc - then if and_case then trimImplies and_case x ps else return (False, p:ps) - else do suc <- impliesRel p x - if suc then if and_case then return (False, p:ps) else trimImplies and_case x ps - else do (addx, newps) <- trimImplies and_case x ps - return (addx, p:newps) - - -- impliesAny(true, x, notx, l) performs: - -- x AND p == False if p => not x, where p in l, - -- impliesAny(true, x, notx, l) performs: - -- x OR p == True if not x => p - -- BUT only when p != x, i.e., avoids comparing x with notx - impliesAny :: Bool -> BTerm -> BTerm -> [BTerm] -> AlgSimplifyM Bool - impliesAny _ _ _ [] = return False - impliesAny and_case x notx (p:ps) - | x == p = impliesAny and_case x notx ps - | otherwise = do - succ' <- if and_case then impliesRel p notx else impliesRel notx p - if succ' then return True - else impliesAny and_case x notx ps - ------------------------------------------------- ---- Syntax-Directed (Brainless) Translators --- ---- scalExp <-> NNumExp --- ---- and negating a scalar expression --- ------------------------------------------------- - --- negates an already simplified scalar expression, --- presumably more efficient than negating and --- then simplifying it. -negateSimplified :: ScalExp -> AlgSimplifyM ScalExp -negateSimplified (SNeg e) = return e -negateSimplified (SNot e) = return e -negateSimplified (SAbs e) = return $ SAbs e -negateSimplified (SSignum e) = - SSignum <$> negateSimplified e -negateSimplified e@(Val v) = do - m1 <- getNeg1 $ scalExpType e - v' <- mulVals m1 v; return $ Val v' -negateSimplified e@Id{} = do - m1 <- getNeg1 $ scalExpType e - return $ STimes (Val m1) e -negateSimplified (SMinus e1 e2) = do -- return $ SMinus e2 e1 - e1' <- negateSimplified e1 - return $ SPlus e1' e2 -negateSimplified (SPlus e1 e2) = do - e1' <- negateSimplified e1 - e2' <- negateSimplified e2 - return $ SPlus e1' e2' -negateSimplified e@(SPow _ _) = do - m1 <- getNeg1 $ scalExpType e - return $ STimes (Val m1) e -negateSimplified (STimes e1 e2) = do - (e1', e2') <- helperNegateMult e1 e2; return $ STimes e1' e2' -negateSimplified (SDiv e1 e2) = do - (e1', e2') <- helperNegateMult e1 e2; return $ SDiv e1' e2' -negateSimplified (SMod e1 e2) = - return $ SMod e1 e2 -negateSimplified (SQuot e1 e2) = do - (e1', e2') <- helperNegateMult e1 e2; return $ SQuot e1' e2' -negateSimplified (SRem e1 e2) = - return $ SRem e1 e2 -negateSimplified (MaxMin ismin ts) = - MaxMin (not ismin) <$> mapM negateSimplified ts -negateSimplified (RelExp LEQ0 e) = - RelExp LTH0 <$> negateSimplified e -negateSimplified (RelExp LTH0 e) = - RelExp LEQ0 <$> negateSimplified e -negateSimplified SLogAnd{} = badAlgSimplifyM "negateSimplified: SLogAnd unimplemented!" -negateSimplified SLogOr{} = badAlgSimplifyM "negateSimplified: SLogOr unimplemented!" - -helperNegateMult :: ScalExp -> ScalExp -> AlgSimplifyM (ScalExp, ScalExp) -helperNegateMult e1 e2 = - case (e1, e2) of - (Val _, _) -> do e1'<- negateSimplified e1; return (e1', e2) - (STimes (Val v) e1r, _) -> do ev <- negateSimplified (Val v); return (STimes ev e1r, e2) - (_, Val _) -> do e2'<- negateSimplified e2; return (e1, e2') - (_, STimes (Val v) e2r) -> do ev <- negateSimplified (Val v); return (e1, STimes ev e2r) - (_, _) -> do e1'<- negateSimplified e1; return (e1', e2) - - -toNumSofP :: ScalExp -> AlgSimplifyM NNumExp -toNumSofP e@(Val _) = return $ NProd [e] $ scalExpType e -toNumSofP e@(Id _ _) = return $ NProd [e] $ scalExpType e -toNumSofP e@SDiv{} = return $ NProd [e] $ scalExpType e -toNumSofP e@SPow{} = return $ NProd [e] $ scalExpType e -toNumSofP (SMinus _ _) = badAlgSimplifyM "toNumSofP: SMinus is not in SofP form!" -toNumSofP (SNeg _) = badAlgSimplifyM "toNumSofP: SNeg is not in SofP form!" -toNumSofP (STimes e1 e2) = do - e2' <- toNumSofP e2 - case e2' of - NProd es2 t -> return $ NProd (e1:es2) t - _ -> badAlgSimplifyM "toNumSofP: STimes nor in SofP form!" -toNumSofP (SPlus e1 e2) = do - let t = scalExpType e1 - e1' <- toNumSofP e1 - e2' <- toNumSofP e2 - case (e1', e2') of - (NSum es1 _, NSum es2 _) -> return $ NSum (es1++es2) t - (NSum es1 _, NProd{}) -> return $ NSum (es1++[e2']) t - (NProd{}, NSum es2 _) -> return $ NSum (e1':es2) t - (NProd{}, NProd{} ) -> return $ NSum [e1', e2'] t -toNumSofP me@MaxMin{} = - return $ NProd [me] $ scalExpType me -toNumSofP s_e = return $ NProd [s_e] $ scalExpType s_e - - -fromNumSofP :: NNumExp -> AlgSimplifyM ScalExp -fromNumSofP (NSum [ ] t) = - Val <$> getZero t -fromNumSofP (NSum [f] _) = fromNumSofP f -fromNumSofP (NSum (f:fs) t) = do - fs_e <- fromNumSofP $ NSum fs t - f_e <- fromNumSofP f - return $ SPlus f_e fs_e -fromNumSofP (NProd [] _) = - badAlgSimplifyM " In fromNumSofP, empty NProd expression! " -fromNumSofP (NProd [f] _) = return f -fromNumSofP (NProd (f:fs) t) = do - fs_e <- fromNumSofP $ NProd fs t - return $ STimes f fs_e ---fromNumSofP _ = do --- pos <- asks pos --- badAlgSimplifyM "fromNumSofP: unimplemented!" ------------------------------------------------------------- ---- Helpers for simplifyScal: getTerms, getMultChildren, --- ---- splitTerm, joinTerm, discriminate ------------------------------------------------------------- - - --- get the list of terms of an expression --- BUG for NMinMax -> should convert it back to a ScalExp -getTerms :: NNumExp -> [NNumExp] -getTerms (NSum es _) = es -getTerms e@NProd{} = [e] - --- get the factors of a term -getMultChildren :: NNumExp -> AlgSimplifyM [ScalExp] -getMultChildren (NSum _ _) = badAlgSimplifyM "getMultChildren, NaryPlus should not be nested 2 levels deep " -getMultChildren (NProd xs _) = return xs - --- split a term into a (multiplicative) value and the rest of the factors. -splitTerm :: NNumExp -> AlgSimplifyM (NNumExp, PrimValue) -splitTerm (NProd [ ] _) = badAlgSimplifyM "splitTerm: Empty n-ary list of factors." -splitTerm (NProd [f] tp) = do - one <- getPos1 tp - case f of - (Val v) -> return (NProd [Val one] tp, v ) - e -> return (NProd [e] tp, one) -splitTerm ne@(NProd (f:fs) tp) = - case f of - (Val v) -> return (NProd fs tp, v) - _ -> do one <- getPos1 tp - return (ne, one) -splitTerm e = do - one <- getPos1 (typeOfNAlg e) - return (e, one) - --- join a value with a list of factors into a term. -joinTerm :: (NNumExp, PrimValue) -> AlgSimplifyM NNumExp -joinTerm ( NSum _ _, _) = badAlgSimplifyM "joinTerm: NaryPlus two levels deep." -joinTerm ( NProd [] _, _) = badAlgSimplifyM "joinTerm: Empty NaryProd." -joinTerm ( NProd (Val l:fs) tp, v) = do - v' <- mulVals v l - let v'Lit = Val v' - return $ NProd (v'Lit:sort fs) tp -joinTerm ( e@(NProd fs tp), v) - | P.oneIsh v = return e - | otherwise = let vExp = Val v - in return $ NProd (vExp:sort fs) tp - --- adds up the values corresponding to identical factors! -discriminate :: [(NNumExp, PrimValue)] -> (NNumExp, PrimValue) -> AlgSimplifyM [(NNumExp, PrimValue)] -discriminate [] e = return [e] -discriminate e@((k,v):t) (k', v') = - if k == k' - then do v'' <- addVals v v' - return ( (k, v'') : t ) - else return ( (k', v') : e ) - ------------------------------------------------------- ---- Trivial Utility Functions --- ------------------------------------------------------- - -getZero :: PrimType -> AlgSimplifyM PrimValue -getZero (IntType t) = return $ value $ intValue t (0::Int) -getZero tp = badAlgSimplifyM ("getZero for type: "++pretty tp) - -getPos1 :: PrimType -> AlgSimplifyM PrimValue -getPos1 (IntType t) = return $ value $ intValue t (1::Int) -getPos1 tp = badAlgSimplifyM ("getOne for type: "++pretty tp) - -getNeg1 :: PrimType -> AlgSimplifyM PrimValue -getNeg1 (IntType t) = return $ value $ intValue t (-1::Int) -getNeg1 tp = badAlgSimplifyM ("getOne for type: "++pretty tp) - -valLTHEQ0 :: RelOp0 -> PrimValue -> AlgSimplifyM Bool -valLTHEQ0 LEQ0 (IntValue iv) = return $ P.intToInt64 iv <= 0 -valLTHEQ0 LTH0 (IntValue iv) = return $ P.intToInt64 iv < 0 -valLTHEQ0 _ _ = badAlgSimplifyM "valLTHEQ0 for non-numeric type!" - -isCt1 :: ScalExp -> Bool -isCt1 (Val v) = P.oneIsh v -isCt1 _ = False - -isCt0 :: ScalExp -> Bool -isCt0 (Val v) = P.zeroIsh v -isCt0 _ = False - - -addVals :: PrimValue -> PrimValue -> AlgSimplifyM PrimValue -addVals (IntValue v1) (IntValue v2) = - return $ IntValue $ P.doAdd v1 v2 -addVals _ _ = - badAlgSimplifyM "addVals: operands not of (the same) numeral type! " - -mulVals :: PrimValue -> PrimValue -> AlgSimplifyM PrimValue -mulVals (IntValue v1) (IntValue v2) = - return $ IntValue $ P.doMul v1 v2 -mulVals v1 v2 = - badAlgSimplifyM $ "mulVals: operands not of (the same) numeral type! "++ - pretty v1++" "++pretty v2 - -divVals :: PrimValue -> PrimValue -> AlgSimplifyM PrimValue -divVals (IntValue v1) (IntValue v2) = - case P.doSDiv v1 v2 of - Just v -> return $ IntValue v - Nothing -> badAlgSimplifyM "Division by zero" -divVals _ _ = - badAlgSimplifyM "divVals: operands not of (the same) numeral type! " - -canDivValsEvenly :: PrimValue -> PrimValue -> AlgSimplifyM Bool -canDivValsEvenly (IntValue v1) (IntValue v2) = - case P.doSMod v1 v2 of - Just v -> return $ P.zeroIsh $ IntValue v - Nothing -> return False -canDivValsEvenly _ _ = - badAlgSimplifyM "canDivValsEvenly: operands not of (the same) numeral type!" - -------------------------------------------------------------- -------------------------------------------------------------- ----- Helpers for the ScalExp and NNumRelLogExp Datatypes ---- -------------------------------------------------------------- -------------------------------------------------------------- - -typeOfNAlg :: NNumExp -> PrimType -typeOfNAlg (NSum _ t) = t -typeOfNAlg (NProd _ t) = t - ----------------------------------------- ----- Helpers for Division and Power ---- ----------------------------------------- -trySimplifyDivRec :: [ScalExp] -> [ScalExp] -> [(NNumExp, PrimValue)] -> - AlgSimplifyM ([ScalExp], [(NNumExp, PrimValue)]) -trySimplifyDivRec [] fs' spl_terms = - return (fs', spl_terms) -trySimplifyDivRec (f:fs) fs' spl_terms = do - res_tmp <- mapM (tryDivProdByOneFact f) spl_terms - let (succs, spl_terms') = unzip res_tmp - if all (==True) succs - then trySimplifyDivRec fs fs' spl_terms' - else trySimplifyDivRec fs (fs'++[f]) spl_terms - - -tryDivProdByOneFact :: ScalExp -> (NNumExp, PrimValue) -> AlgSimplifyM (Bool, (NNumExp, PrimValue)) -tryDivProdByOneFact (Val f) (e, v) = do - succc <- canDivValsEvenly v f - if succc then do vres <- divVals v f - return (True, (e, vres)) - else return (False,(e, v) ) - -tryDivProdByOneFact _ pev@(NProd [] _, _) = return (False, pev) -tryDivProdByOneFact f pev@(NProd (t:tfs) tp, v) = do - (succc, newt) <- tryDivTriv t f - one <- getPos1 tp - if not succc - then do (succ', (tfs', v')) <- tryDivProdByOneFact f (NProd tfs tp, v) - case (succ', tfs') of - (True, NProd (Val vv:tfs'') _) -> do - vres <- mulVals v' vv - return (True, (NProd (t:tfs'') tp, vres)) - (True, NProd tfs'' _) -> return (True, (NProd (t:tfs'') tp, v')) - (_, _) -> return (False, pev) - else case (newt, tfs) of - (Val vv, _) -> do vres <- mulVals vv v - return $ if null tfs - then (True, (NProd [Val one] tp, vres)) - else (True, (NProd tfs tp, vres)) - (_, _) -> return (True, (NProd (newt:tfs) tp, v)) - -tryDivProdByOneFact _ (NSum _ _, _) = - badAlgSimplifyM "tryDivProdByOneFact: unreachable case NSum reached!" - - -tryDivTriv :: ScalExp -> ScalExp -> AlgSimplifyM (Bool, ScalExp) -tryDivTriv (SPow a e1) (SPow d e2) - | a == d && e1 == e2 = do one <- getPos1 $ scalExpType a - return (True, Val one) - | a == d = do - let tp = scalExpType a - one <- getPos1 tp - e1me2 <- simplifyScal $ SMinus e1 e2 - case (tp, e1me2) of - (IntType _, Val v) | P.zeroIsh v -> - return (True, Val one) - (IntType _, Val v) | P.oneIsh v -> - return (True, a) - (IntType _, _) -> do - e2me1 <- negateSimplified e1me2 - e2me1_sop <- toNumSofP e2me1 - p' <- simplifyNRel $ NRelExp LTH0 e2me1_sop - return $ if p' == LogCt True - then (True, SPow a e1me2) - else (False, SDiv (SPow a e1) (SPow d e2)) - - (_, _) -> return (False, SDiv (SPow a e1) (SPow d e2)) - - | otherwise = return (False, SDiv (SPow a e1) (SPow d e2)) - -tryDivTriv (SPow a e1) b - | a == b = do one <- getPos1 $ scalExpType a - tryDivTriv (SPow a e1) (SPow a (Val one)) - | otherwise = return (False, SDiv (SPow a e1) b) - -tryDivTriv b (SPow a e1) - | a == b = do one <- getPos1 $ scalExpType a - tryDivTriv (SPow a (Val one)) (SPow a e1) - | otherwise = return (False, SDiv b (SPow a e1)) - -tryDivTriv t f - | t == f = do one <- getPos1 $ scalExpType t - return (True, Val one) - | otherwise = return (False, SDiv t f) - - -{- -mkRelExp :: Int -> (RangesRep, ScalExp, ScalExp) -mkRelExp 1 = - let (i',j',n',p',m') = (tident "int i", tident "int j", tident "int n", tident "int p", tident "int m") - (i,j,n,p,m) = (Id i', Id j', Id n', Id p', Id m') - one = Val (IntVal 1) - min_p_nm1 = MaxMin True [p, SMinus n one] - hash = M.fromList $ [ (identName n', ( 1::Int, Just (Val (IntVal 1)), Nothing ) ), - (identName p', ( 1::Int, Just (Val (IntVal 0)), Nothing ) ), - (identName i', ( 5::Int, Just (Val (IntVal 0)), Just min_p_nm1 ) ) - , (identName j', ( 9::Int, Just (Val (IntVal 0)), Just i ) ) - ] -- M.Map VName (Int, Maybe ScalExp, Maybe ScalExp) - ij_p_j_p_1_m_m = SMinus (SPlus (STimes i j) (SPlus j one)) m - rel1 = RelExp LTH0 ij_p_j_p_1_m_m - m_ij_m_j_m_2 = SNeg ( SPlus (STimes i j) (SPlus j (Val (IntVal 2))) ) - rel2 = RelExp LTH0 m_ij_m_j_m_2 - - in (hash, rel1, rel2) -mkRelExp 2 = - let (i',a',b',l',u') = (tident "int i", tident "int a", tident "int b", tident "int l", tident "int u") - (i,a,b,l,u) = (Id i', Id a', Id b', Id l', Id u') - hash = M.fromList $ [ (identName i', ( 5::Int, Just l, Just u ) ) ] - ai_p_b = SPlus (STimes a i) b - rel1 = RelExp LTH0 ai_p_b - - in (hash, rel1, rel1) -mkRelExp 3 = - let (i',j',n',m') = (tident "int i", tident "int j", tident "int n", tident "int m") - (i,j,n,m) = (Id i', Id j', Id n', Id m') - one = Val (IntVal 1) - two = Val (IntVal 2) - min_j_nm1 = MaxMin True [MaxMin False [Val (IntVal 0), SMinus i (STimes two n)], SMinus n one] - hash = M.fromList $ [ (identName n', ( 1::Int, Just (Val (IntVal 1)), Nothing ) ), - (identName m', ( 2::Int, Just (Val (IntVal 1)), Nothing ) ), - (identName i', ( 5::Int, Just (Val (IntVal 0)), Just (SMinus m one) ) ) - , (identName j', ( 9::Int, Just (Val (IntVal 0)), Just min_j_nm1 ) ) - ] -- M.Map VName (Int, Maybe ScalExp, Maybe ScalExp) - ij_m_m = SMinus (STimes i j) m - rel1 = RelExp LTH0 ij_m_m --- rel3 = RelExp LTH0 (SMinus i (SPlus (STimes two n) j)) - m_ij_m_1 = SMinus (Val (IntVal (-1))) (STimes i j) - rel2 = RelExp LTH0 m_ij_m_1 - --- simpl_exp = SDiv (MaxMin True [SMinus (Val (IntVal 0)) (STimes i j), SNeg (STimes i n) ]) --- (STimes i j) --- rel4 = RelExp LTH0 simpl_exp - - in (hash, rel1, rel2) - -mkRelExp _ = let hash = M.empty - rel = RelExp LTH0 (Val (IntVal (-1))) - in (hash, rel, rel) --} diff --git a/src/Futhark/Analysis/Alias.hs b/src/Futhark/Analysis/Alias.hs --- a/src/Futhark/Analysis/Alias.hs +++ b/src/Futhark/Analysis/Alias.hs @@ -33,8 +33,8 @@ analyseFun :: (ASTLore lore, CanBeAliased (Op lore)) => FunDef lore -> FunDef (Aliases lore) -analyseFun (FunDef entry fname restype params body) = - FunDef entry fname restype params body' +analyseFun (FunDef entry attrs fname restype params body) = + FunDef entry attrs fname restype params body' where body' = analyseBody mempty body -- | Pre-existing aliases for variables. Used to add transitive @@ -62,7 +62,7 @@ analyseStm aliases (Let pat (StmAux cs attrs dec) e) = let e' = analyseExp aliases e pat' = addAliasesToPattern pat e' - lore' = (Names' $ consumedInExp e', dec) + lore' = (AliasDec $ consumedInExp e', dec) in Let pat' (StmAux cs attrs lore') e' analyseExp :: (ASTLore lore, CanBeAliased (Op lore)) => @@ -74,11 +74,11 @@ let Body ((tb_als, tb_cons), tb_dec) tb_stms tb_res = analyseBody aliases tb Body ((fb_als, fb_cons), fb_dec) fb_stms fb_res = analyseBody aliases fb cons = tb_cons <> fb_cons - isConsumed v = any (`nameIn` unNames cons) $ + isConsumed v = any (`nameIn` unAliases cons) $ v : namesToList (M.findWithDefault mempty v aliases) - notConsumed = Names' . namesFromList . + notConsumed = AliasDec . namesFromList . filter (not . isConsumed) . - namesToList . unNames + namesToList . unAliases tb_als' = map notConsumed tb_als fb_als' = map notConsumed fb_als tb' = Body ((tb_als', tb_cons), tb_dec) tb_stms tb_res diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs --- a/src/Futhark/Analysis/CallGraph.hs +++ b/src/Futhark/Analysis/CallGraph.hs @@ -96,10 +96,12 @@ return body } --- | The set of all functions that are called noinline somewhere. +-- | The set of all functions that are called noinline somewhere, or +-- have a noinline attribute on their definition. findNoninlined :: Prog SOACS -> S.Set Name findNoninlined prog = - foldMap onStm $ foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog + foldMap noinlineDef (progFuns prog) <> + foldMap onStm (foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog) where onStm :: Stm -> S.Set Name onStm (Let _ aux (Apply fname _ _ _)) | "noinline" `inAttrs` stmAuxAttrs aux = @@ -116,3 +118,9 @@ return lam } } + + noinlineDef fd + | "noinline" `inAttrs` funDefAttrs fd = + S.singleton $ funDefName fd + | otherwise = + mempty 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 @@ -131,7 +131,6 @@ primOpMetrics Manifest{} = seen "Manifest" primOpMetrics Iota{} = seen "Iota" primOpMetrics Replicate{} = seen "Replicate" -primOpMetrics Repeat{} = seen "Repeat" primOpMetrics Scratch{} = seen "Scratch" primOpMetrics Reshape{} = seen "Reshape" primOpMetrics Rearrange{} = seen "Rearrange" 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 @@ -184,18 +184,24 @@ fromRational = ValueExp . FloatValue . Float64Value . fromRational instance Pretty v => IntegralExp (PrimExp v) where - x `div` y | Just z <- msum [asIntOp SDiv x y, asFloatOp FDiv x y] = constFoldPrimExp z + x `div` y | Just z <- msum [asIntOp (`SDiv` Unsafe) x y, + asFloatOp FDiv x y] = + constFoldPrimExp z | otherwise = numBad "div" (x,y) - x `mod` y | Just z <- msum [asIntOp SMod x y] = z + x `mod` y | Just z <- msum [asIntOp (`SMod` Unsafe) x y] = z | otherwise = numBad "mod" (x,y) x `quot` y | oneIshExp y = x - | Just z <- msum [asIntOp SQuot x y] = constFoldPrimExp z + | Just z <- msum [asIntOp (`SQuot` Unsafe) x y] = constFoldPrimExp z | otherwise = numBad "quot" (x,y) - x `rem` y | Just z <- msum [asIntOp SRem x y] = constFoldPrimExp z + x `rem` y | Just z <- msum [asIntOp (`SRem` Unsafe) x y] = constFoldPrimExp z | otherwise = numBad "rem" (x,y) + + x `divUp` y | Just z <- msum [asIntOp (`SDivUp` Unsafe) x y] = + constFoldPrimExp z + | otherwise = numBad "divRoundingUp" (x,y) sgn (ValueExp (IntValue i)) = Just $ signum $ valueIntegral i sgn _ = Nothing diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs --- a/src/Futhark/Analysis/PrimExp/Convert.hs +++ b/src/Futhark/Analysis/PrimExp/Convert.hs @@ -9,6 +9,8 @@ , replaceInPrimExp , replaceInPrimExpM , substituteInPrimExp + , primExpSlice + , subExpSlice -- * Module reexport , module Futhark.Analysis.PrimExp @@ -103,3 +105,11 @@ -> PrimExp v -> PrimExp v substituteInPrimExp tab = replaceInPrimExp $ \v t -> fromMaybe (LeafExp v t) $ M.lookup v tab + +-- | Convert a 'SubExp' slice to a 'PrimExp' slice. +primExpSlice :: Slice SubExp -> Slice (PrimExp VName) +primExpSlice = map $ fmap $ primExpFromSubExp int32 + +-- | Convert a 'PrimExp' slice to a 'SubExp' slice. +subExpSlice :: MonadBinder m => Slice (PrimExp VName) -> m (Slice SubExp) +subExpSlice = mapM $ traverse $ toSubExp "slice" diff --git a/src/Futhark/Analysis/PrimExp/Generalize.hs b/src/Futhark/Analysis/PrimExp/Generalize.hs --- a/src/Futhark/Analysis/PrimExp/Generalize.hs +++ b/src/Futhark/Analysis/PrimExp/Generalize.hs @@ -4,63 +4,62 @@ leastGeneralGeneralization ) where -import Control.Monad import Data.List (elemIndex) - import Futhark.Analysis.PrimExp import Futhark.IR.Syntax.Core (Ext(..)) -- | Generalize two 'PrimExp's of the the same type. leastGeneralGeneralization :: (Eq v) => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v -> - Maybe (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) + (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) leastGeneralGeneralization m exp1@(LeafExp v1 t1) exp2@(LeafExp v2 _) = if v1 == v2 then - Just (LeafExp (Free v1) t1, m) + (LeafExp (Free v1) t1, m) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(ValueExp v1) exp2@(ValueExp v2) = if v1 == v2 then - Just (ValueExp v1, m) + (ValueExp v1, m) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(BinOpExp op1 e11 e12) exp2@(BinOpExp op2 e21 e22) = - if op1 == op2 then do - (e1, m1) <- leastGeneralGeneralization m e11 e21 - (e2, m2) <- leastGeneralGeneralization m1 e12 e22 - return (BinOpExp op1 e1 e2, m2) + if op1 == op2 then + let (e1, m1) = leastGeneralGeneralization m e11 e21 + (e2, m2) = leastGeneralGeneralization m1 e12 e22 + in (BinOpExp op1 e1 e2, m2) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(CmpOpExp op1 e11 e12) exp2@(CmpOpExp op2 e21 e22) = - if op1 == op2 then do - (e1, m1) <- leastGeneralGeneralization m e11 e21 - (e2, m2) <- leastGeneralGeneralization m1 e12 e22 - return (CmpOpExp op1 e1 e2, m2) + if op1 == op2 then + let (e1, m1) = leastGeneralGeneralization m e11 e21 + (e2, m2) = leastGeneralGeneralization m1 e12 e22 + in (CmpOpExp op1 e1 e2, m2) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(UnOpExp op1 e1) exp2@(UnOpExp op2 e2) = - if op1 == op2 then do - (e, m1) <- leastGeneralGeneralization m e1 e2 - return (UnOpExp op1 e, m1) + if op1 == op2 then + let (e, m1) = leastGeneralGeneralization m e1 e2 + in (UnOpExp op1 e, m1) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(ConvOpExp op1 e1) exp2@(ConvOpExp op2 e2) = - if op1 == op2 then do - (e, m1) <- leastGeneralGeneralization m e1 e2 - return (ConvOpExp op1 e, m1) + if op1 == op2 then + let (e, m1) = leastGeneralGeneralization m e1 e2 + in (ConvOpExp op1 e, m1) else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1@(FunExp s1 args1 t1) exp2@(FunExp s2 args2 _) = - if s1 == s2 && length args1 == length args2 then do - (args, m') <- foldM (\(arg_acc, m_acc) (a1, a2) -> do - (a, m'') <- leastGeneralGeneralization m_acc a1 a2 - return (a : arg_acc, m'') - ) ([], m) (zip args1 args2) - return (FunExp s1 (reverse args) t1, m') + if s1 == s2 && length args1 == length args2 then + let (args, m') = + foldl (\(arg_acc, m_acc) (a1, a2) -> + let (a, m'') = leastGeneralGeneralization m_acc a1 a2 + in (a : arg_acc, m'') + ) ([], m) (zip args1 args2) + in (FunExp s1 (reverse args) t1, m') else - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 leastGeneralGeneralization m exp1 exp2 = - Just $ generalize m exp1 exp2 + generalize m exp1 exp2 generalize :: Eq v => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v -> (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) generalize m exp1 exp2 = diff --git a/src/Futhark/Analysis/Range.hs b/src/Futhark/Analysis/Range.hs deleted file mode 100644 --- a/src/Futhark/Analysis/Range.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | Perform range analysis of a program or other fragment. -module Futhark.Analysis.Range - ( rangeAnalysis - , runRangeM - , RangeM - , analyseLambda - , analyseStms - ) - where - -import qualified Data.Map.Strict as M -import Control.Monad.Reader -import Data.List (nub) - -import qualified Futhark.Analysis.ScalExp as SE -import Futhark.IR.Ranges -import Futhark.Analysis.AlgSimplify as AS - --- Entry point - --- | Perform variable range analysis on the given program, returning a --- program with embedded range annotations. -rangeAnalysis :: (ASTLore lore, CanBeRanged (Op lore)) => - Prog lore -> Prog (Ranges lore) -rangeAnalysis (Prog consts funs) = - Prog (runRangeM $ mapM analyseStm consts) (map analyseFun funs) - --- Implementation - -analyseFun :: (ASTLore lore, CanBeRanged (Op lore)) => - FunDef lore -> FunDef (Ranges lore) -analyseFun (FunDef entry fname restype params body) = - runRangeM $ bindFunParams params $ - FunDef entry fname restype params <$> analyseBody body - -analyseBody :: (ASTLore lore, CanBeRanged (Op lore)) => - Body lore - -> RangeM (Body (Ranges lore)) -analyseBody (Body lore origbnds result) = - analyseStms origbnds $ \bnds' -> - return $ mkRangedBody lore bnds' result - --- | Perform range analysis on some statements, taking a continuation --- where the ranges of the variables bound by the statements is --- in scope. -analyseStms :: (ASTLore lore, CanBeRanged (Op lore)) => - Stms lore - -> (Stms (Ranges lore) -> RangeM a) - -> RangeM a -analyseStms = analyseStms' mempty . stmsToList - where analyseStms' acc [] m = - m acc - analyseStms' acc (bnd:bnds) m = do - bnd' <- analyseStm bnd - bindPattern (stmPattern bnd') $ - analyseStms' (acc <> oneStm bnd') bnds m - -analyseStm :: (ASTLore lore, CanBeRanged (Op lore)) => - Stm lore -> RangeM (Stm (Ranges lore)) -analyseStm (Let pat lore e) = do - e' <- analyseExp e - pat' <- simplifyPatRanges $ addRangesToPattern pat e' - return $ Let pat' lore e' - -analyseExp :: (ASTLore lore, CanBeRanged (Op lore)) => - Exp lore - -> RangeM (Exp (Ranges lore)) -analyseExp = mapExpM analyse - where analyse = - Mapper { mapOnSubExp = return - , mapOnVName = return - , mapOnBody = const analyseBody - , mapOnRetType = return - , mapOnBranchType = return - , mapOnFParam = return - , mapOnLParam = return - , mapOnOp = return . addOpRanges - } - --- | Perform range analysis on a lambda. -analyseLambda :: (ASTLore lore, CanBeRanged (Op lore)) => - Lambda lore - -> RangeM (Lambda (Ranges lore)) -analyseLambda lam = do - body <- analyseBody $ lambdaBody lam - return $ lam { lambdaBody = body - , lambdaParams = lambdaParams lam - } - --- Monad and utility definitions - -type RangeEnv = M.Map VName Range - -emptyRangeEnv :: RangeEnv -emptyRangeEnv = M.empty - --- | The range analysis monad. -type RangeM = Reader RangeEnv - --- | Run a 'RangeM' action. -runRangeM :: RangeM a -> a -runRangeM = flip runReader emptyRangeEnv - -bindFunParams :: Typed dec => [Param dec] -> RangeM a -> RangeM a -bindFunParams [] m = - m -bindFunParams (param:params) m = do - ranges <- rangesRep - local bindFunParam $ - local (refineDimensionRanges ranges dims) $ - bindFunParams params m - where bindFunParam = M.insert (paramName param) unknownRange - dims = arrayDims $ paramType param - -bindPattern :: Typed dec => PatternT (Range, dec) -> RangeM a -> RangeM a -bindPattern pat m = do - ranges <- rangesRep - local bindPatElems $ - local (refineDimensionRanges ranges dims) - m - where bindPatElems env = - foldl bindPatElem env $ patternElements pat - bindPatElem env patElem = - M.insert (patElemName patElem) (fst $ patElemDec patElem) env - dims = nub $ concatMap arrayDims $ patternTypes pat - -refineDimensionRanges :: AS.RangesRep -> [SubExp] - -> RangeEnv -> RangeEnv -refineDimensionRanges ranges = flip $ foldl refineShape - where refineShape env (Var dim) = - refineRange ranges dim dimBound env - refineShape env _ = - env - -- A dimension is never negative. - dimBound :: Range - dimBound = (Just $ ScalarBound 0, - Nothing) - -refineRange :: AS.RangesRep -> VName -> Range -> RangeEnv - -> RangeEnv -refineRange = - M.insertWith . refinedRange - --- New range, old range, result range. -refinedRange :: AS.RangesRep -> Range -> Range -> Range -refinedRange ranges (new_lower, new_upper) (old_lower, old_upper) = - (simplifyBound ranges $ refineLowerBound new_lower old_lower, - simplifyBound ranges $ refineUpperBound new_upper old_upper) - --- New bound, old bound, result bound. -refineLowerBound :: Bound -> Bound -> Bound -refineLowerBound = flip maximumBound - --- New bound, old bound, result bound. -refineUpperBound :: Bound -> Bound -> Bound -refineUpperBound = flip minimumBound - -lookupRange :: VName -> RangeM Range -lookupRange = asks . M.findWithDefault unknownRange - -simplifyPatRanges :: PatternT (Range, dec) - -> RangeM (PatternT (Range, dec)) -simplifyPatRanges (Pattern context values) = - Pattern <$> mapM simplifyPatElemRange context <*> mapM simplifyPatElemRange values - where simplifyPatElemRange patElem = do - let (range, innerdec) = patElemDec patElem - range' <- simplifyRange range - return $ setPatElemLore patElem (range', innerdec) - -simplifyRange :: Range -> RangeM Range -simplifyRange (lower, upper) = do - ranges <- rangesRep - lower' <- simplifyBound ranges <$> betterLowerBound lower - upper' <- simplifyBound ranges <$> betterUpperBound upper - return (lower', upper') - -simplifyBound :: AS.RangesRep -> Bound -> Bound -simplifyBound ranges = fmap $ simplifyKnownBound ranges - -simplifyKnownBound :: AS.RangesRep -> KnownBound -> KnownBound -simplifyKnownBound ranges bound - | Just se <- boundToScalExp bound = - ScalarBound $ AS.simplify se ranges -simplifyKnownBound ranges (MinimumBound b1 b2) = - MinimumBound (simplifyKnownBound ranges b1) (simplifyKnownBound ranges b2) -simplifyKnownBound ranges (MaximumBound b1 b2) = - MaximumBound (simplifyKnownBound ranges b1) (simplifyKnownBound ranges b2) -simplifyKnownBound _ bound = - bound - -betterLowerBound :: Bound -> RangeM Bound -betterLowerBound (Just (ScalarBound (SE.Id v t))) = do - range <- lookupRange v - return $ Just $ case range of - (Just lower, _) -> lower - _ -> ScalarBound $ SE.Id v t -betterLowerBound bound = - return bound - -betterUpperBound :: Bound -> RangeM Bound -betterUpperBound (Just (ScalarBound (SE.Id v t))) = do - range <- lookupRange v - return $ Just $ case range of - (_, Just upper) -> upper - _ -> ScalarBound $ SE.Id v t -betterUpperBound bound = - return bound - --- The algebraic simplifier requires a loop nesting level for each --- range. We just put a zero because I don't think it's used for --- anything in this case. -rangesRep :: RangeM AS.RangesRep -rangesRep = asks $ M.map addLeadingZero - where addLeadingZero (x,y) = - (0, boundToScalExp =<< x, boundToScalExp =<< y) diff --git a/src/Futhark/Analysis/ScalExp.hs b/src/Futhark/Analysis/ScalExp.hs deleted file mode 100644 --- a/src/Futhark/Analysis/ScalExp.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | A legacy representation of scalar expressions used solely for --- algebraic simplification. Never use this. Use --- "Futhark.Analysis.PrimExp" instead. -module Futhark.Analysis.ScalExp - ( RelOp0(..) - , ScalExp(..) - , scalExpType - , scalExpSize - , subExpToScalExp - , toScalExp - , expandScalExp - , LookupVar - , module Futhark.IR.Primitive - ) -where - -import Data.List (find) -import Data.Maybe - -import Futhark.IR.Primitive hiding (SQuot, SRem, SDiv, SMod, SSignum) -import Futhark.IR hiding (SQuot, SRem, SDiv, SMod, SSignum) -import qualified Futhark.IR as AST -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import Futhark.Util.Pretty hiding (pretty) - ------------------------------------------------------------------ --- BINARY OPERATORS for Numbers -- --- Note that MOD, BAND, XOR, BOR, SHIFTR, SHIFTL not supported -- --- `a SHIFTL/SHIFTR p' can be translated if desired as as -- --- `a * 2^p' or `a / 2^p -- ------------------------------------------------------------------ - --- | Relational operators. -data RelOp0 = LTH0 - | LEQ0 - deriving (Eq, Ord, Enum, Bounded, Show) - --- | Representation of a scalar expression, which is: --- --- (i) an algebraic expression, e.g., min(a+b, a*b), --- --- (ii) a relational expression: a+b < 5, --- --- (iii) a logical expression: e1 and (not (a+b>5) -data ScalExp= Val PrimValue - | Id VName PrimType - | SNeg ScalExp - | SNot ScalExp - | SAbs ScalExp - | SSignum ScalExp - | SPlus ScalExp ScalExp - | SMinus ScalExp ScalExp - | STimes ScalExp ScalExp - | SPow ScalExp ScalExp - | SDiv ScalExp ScalExp - | SMod ScalExp ScalExp - | SQuot ScalExp ScalExp - | SRem ScalExp ScalExp - | MaxMin Bool [ScalExp] - | RelExp RelOp0 ScalExp - | SLogAnd ScalExp ScalExp - | SLogOr ScalExp ScalExp - deriving (Eq, Ord, Show) - -instance Num ScalExp where - 0 + y = y - x + 0 = x - x + y = SPlus x y - - x - 0 = x - x - y = SMinus x y - - 0 * _ = 0 - _ * 0 = 0 - 1 * y = y - y * 1 = y - x * y = STimes x y - - abs = SAbs - signum = SSignum - fromInteger = Val . IntValue . Int32Value . fromInteger -- probably not OK - negate = SNeg - -instance Pretty ScalExp where - pprPrec _ (Val val) = ppr val - pprPrec _ (Id v _) = ppr v - pprPrec _ (SNeg e) = text "-" <> pprPrec 9 e - pprPrec _ (SNot e) = text "not" <+> pprPrec 9 e - pprPrec _ (SAbs e) = text "abs" <+> pprPrec 9 e - pprPrec _ (SSignum e) = text "signum" <+> pprPrec 9 e - pprPrec prec (SPlus x y) = ppBinOp prec "+" 4 4 x y - pprPrec prec (SMinus x y) = ppBinOp prec "-" 4 10 x y - pprPrec prec (SPow x y) = ppBinOp prec "^" 6 6 x y - pprPrec prec (STimes x y) = ppBinOp prec "*" 5 5 x y - pprPrec prec (SDiv x y) = ppBinOp prec "/" 5 10 x y - pprPrec prec (SMod x y) = ppBinOp prec "%" 5 10 x y - pprPrec prec (SQuot x y) = ppBinOp prec "//" 5 10 x y - pprPrec prec (SRem x y) = ppBinOp prec "%%" 5 10 x y - pprPrec prec (SLogOr x y) = ppBinOp prec "||" 0 0 x y - pprPrec prec (SLogAnd x y) = ppBinOp prec "&&" 1 1 x y - pprPrec prec (RelExp LTH0 e) = ppBinOp prec "<" 2 2 e (0::Int) - pprPrec prec (RelExp LEQ0 e) = ppBinOp prec "<=" 2 2 e (0::Int) - pprPrec _ (MaxMin True es) = text "min" <> parens (commasep $ map ppr es) - pprPrec _ (MaxMin False es) = text "max" <> parens (commasep $ map ppr es) - -ppBinOp :: (Pretty a, Pretty b) => Int -> String -> Int -> Int -> a -> b -> Doc -ppBinOp p bop precedence rprecedence x y = - parensIf (p > precedence) $ - pprPrec precedence x <+/> - text bop <+> - pprPrec rprecedence y - -instance Substitute ScalExp where - substituteNames subst e = - case e of Id v t -> Id (substituteNames subst v) t - Val v -> Val v - SNeg x -> SNeg $ substituteNames subst x - SNot x -> SNot $ substituteNames subst x - SAbs x -> SAbs $ substituteNames subst x - SSignum x -> SSignum $ substituteNames subst x - SPlus x y -> substituteNames subst x `SPlus` substituteNames subst y - SMinus x y -> substituteNames subst x `SMinus` substituteNames subst y - SPow x y -> substituteNames subst x `SPow` substituteNames subst y - STimes x y -> substituteNames subst x `STimes` substituteNames subst y - SDiv x y -> substituteNames subst x `SDiv` substituteNames subst y - SMod x y -> substituteNames subst x `SMod` substituteNames subst y - SQuot x y -> substituteNames subst x `SDiv` substituteNames subst y - SRem x y -> substituteNames subst x `SRem` substituteNames subst y - MaxMin m es -> MaxMin m $ map (substituteNames subst) es - RelExp r x -> RelExp r $ substituteNames subst x - SLogAnd x y -> substituteNames subst x `SLogAnd` substituteNames subst y - SLogOr x y -> substituteNames subst x `SLogOr` substituteNames subst y - -instance Rename ScalExp where - rename = substituteRename - --- | The type of a scalar expression. -scalExpType :: ScalExp -> PrimType -scalExpType (Val v) = primValueType v -scalExpType (Id _ t) = t -scalExpType (SNeg e) = scalExpType e -scalExpType (SNot _) = Bool -scalExpType (SAbs e) = scalExpType e -scalExpType (SSignum e) = scalExpType e -scalExpType (SPlus e _) = scalExpType e -scalExpType (SMinus e _) = scalExpType e -scalExpType (STimes e _) = scalExpType e -scalExpType (SDiv e _) = scalExpType e -scalExpType (SMod e _) = scalExpType e -scalExpType (SPow e _) = scalExpType e -scalExpType (SQuot e _) = scalExpType e -scalExpType (SRem e _) = scalExpType e -scalExpType (SLogAnd _ _) = Bool -scalExpType (SLogOr _ _) = Bool -scalExpType (RelExp _ _) = Bool -scalExpType (MaxMin _ []) = IntType Int32 -- arbitrary and probably wrong. -scalExpType (MaxMin _ (e:_)) = scalExpType e - --- | Number of nodes in the scalar expression. -scalExpSize :: ScalExp -> Int -scalExpSize Val{} = 1 -scalExpSize Id{} = 1 -scalExpSize (SNeg e) = scalExpSize e -scalExpSize (SNot e) = scalExpSize e -scalExpSize (SAbs e) = scalExpSize e -scalExpSize (SSignum e) = scalExpSize e -scalExpSize (SPlus x y) = scalExpSize x + scalExpSize y -scalExpSize (SMinus x y) = scalExpSize x + scalExpSize y -scalExpSize (STimes x y) = scalExpSize x + scalExpSize y -scalExpSize (SDiv x y) = scalExpSize x + scalExpSize y -scalExpSize (SMod x y) = scalExpSize x + scalExpSize y -scalExpSize (SPow x y) = scalExpSize x + scalExpSize y -scalExpSize (SQuot x y) = scalExpSize x + scalExpSize y -scalExpSize (SRem x y) = scalExpSize x + scalExpSize y -scalExpSize (SLogAnd x y) = scalExpSize x + scalExpSize y -scalExpSize (SLogOr x y) = scalExpSize x + scalExpSize y -scalExpSize (RelExp _ x) = scalExpSize x -scalExpSize (MaxMin _ []) = 0 -scalExpSize (MaxMin _ es) = sum $ map scalExpSize es - --- | A function that checks whether a variable name corresponds to a --- scalar expression. -type LookupVar = VName -> Maybe ScalExp - --- | Non-recursively convert a subexpression to a 'ScalExp'. The --- (scalar) type of the subexpression must be given in advance. -subExpToScalExp :: SubExp -> PrimType -> ScalExp -subExpToScalExp (Var v) t = Id v t -subExpToScalExp (Constant val) _ = Val val - --- | Recursively convert an expression to a scalar expression. -toScalExp :: (HasScope t f, Monad f) => - LookupVar -> Exp lore -> f (Maybe ScalExp) -toScalExp look (BasicOp (SubExp (Var v))) - | Just se <- look v = - return $ Just se - | otherwise = do - t <- lookupType v - case t of - Prim bt | typeIsOK bt -> - return $ Just $ Id v bt - _ -> - return Nothing -toScalExp _ (BasicOp (SubExp (Constant val))) - | typeIsOK $ primValueType val = - return $ Just $ Val val -toScalExp look (BasicOp (CmpOp (CmpSlt _) x y)) = - Just . RelExp LTH0 <$> (sminus <$> subExpToScalExp' look x <*> subExpToScalExp' look y) -toScalExp look (BasicOp (CmpOp (CmpSle _) x y)) = - Just . RelExp LEQ0 <$> (sminus <$> subExpToScalExp' look x <*> subExpToScalExp' look y) -toScalExp look (BasicOp (CmpOp (CmpEq t) x y)) - | typeIsOK t = do - x' <- subExpToScalExp' look x - y' <- subExpToScalExp' look y - return $ Just $ case t of - Bool -> - SLogAnd x' y' `SLogOr` SLogAnd (SNot x') (SNot y') - _ -> - RelExp LEQ0 (x' `sminus` y') `SLogAnd` RelExp LEQ0 (y' `sminus` x') -toScalExp look (BasicOp (BinOp (Sub t _) (Constant x) y)) - | typeIsOK $ IntType t, zeroIsh x = - Just . SNeg <$> subExpToScalExp' look y -toScalExp look (BasicOp (UnOp AST.Not e)) = - Just . SNot <$> subExpToScalExp' look e -toScalExp look (BasicOp (BinOp bop x y)) - | Just f <- binOpScalExp bop = - Just <$> (f <$> subExpToScalExp' look x <*> subExpToScalExp' look y) - -toScalExp _ _ = return Nothing - -typeIsOK :: PrimType -> Bool -typeIsOK = (`elem` Bool : map IntType allIntTypes) - -subExpToScalExp' :: HasScope t f => - LookupVar -> SubExp -> f ScalExp -subExpToScalExp' look (Var v) - | Just se <- look v = - pure se - | otherwise = - withType <$> lookupType v - where withType (Prim t) = - subExpToScalExp (Var v) t - withType t = - error $ "Cannot create ScalExp from variable " ++ pretty v ++ - " of type " ++ pretty t -subExpToScalExp' _ (Constant val) = - pure $ Val val - --- | If you have a scalar expression that has been created with --- incomplete symbol table information, you can use this function to --- grow its 'Id' leaves. -expandScalExp :: LookupVar -> ScalExp -> ScalExp -expandScalExp _ (Val v) = Val v -expandScalExp look (Id v t) = fromMaybe (Id v t) $ look v -expandScalExp look (SNeg se) = SNeg $ expandScalExp look se -expandScalExp look (SNot se) = SNot $ expandScalExp look se -expandScalExp look (SAbs se) = SAbs $ expandScalExp look se -expandScalExp look (SSignum se) = SSignum $ expandScalExp look se -expandScalExp look (MaxMin b ses) = MaxMin b $ map (expandScalExp look) ses -expandScalExp look (SPlus x y) = SPlus (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SMinus x y) = SMinus (expandScalExp look x) (expandScalExp look y) -expandScalExp look (STimes x y) = STimes (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SDiv x y) = SDiv (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SMod x y) = SMod (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SQuot x y) = SQuot (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SRem x y) = SRem (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SPow x y) = SPow (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SLogAnd x y) = SLogAnd (expandScalExp look x) (expandScalExp look y) -expandScalExp look (SLogOr x y) = SLogOr (expandScalExp look x) (expandScalExp look y) -expandScalExp look (RelExp relop x) = RelExp relop $ expandScalExp look x - --- | "Smart constructor" that checks whether we are subtracting zero, --- and if so just returns the first argument. -sminus :: ScalExp -> ScalExp -> ScalExp -sminus x (Val v) | zeroIsh v = x -sminus x y = x `SMinus` y - - -- XXX: Only integers and booleans, OK? -binOpScalExp :: BinOp -> Maybe (ScalExp -> ScalExp -> ScalExp) -binOpScalExp bop = fmap snd . find ((==bop) . fst) $ - concatMap intOps allIntTypes ++ - [ (LogAnd, SLogAnd), (LogOr, SLogOr) ] - where intOps t = [ (Add t OverflowWrap, SPlus) - , (Sub t OverflowWrap, SMinus) - , (Mul t OverflowWrap, STimes) - , (AST.SDiv t, SDiv) - , (AST.Pow t, SPow) - , (AST.SMax t, \x y -> MaxMin False [x,y]) - , (AST.SMin t, \x y -> MaxMin True [x,y]) - ] - -instance FreeIn ScalExp where - freeIn' (Val _) = mempty - freeIn' (Id i _) = fvName i - freeIn' (SNeg e) = freeIn' e - freeIn' (SNot e) = freeIn' e - freeIn' (SAbs e) = freeIn' e - freeIn' (SSignum e) = freeIn' e - freeIn' (SPlus x y) = freeIn' x <> freeIn' y - freeIn' (SMinus x y) = freeIn' x <> freeIn' y - freeIn' (SPow x y) = freeIn' x <> freeIn' y - freeIn' (STimes x y) = freeIn' x <> freeIn' y - freeIn' (SDiv x y) = freeIn' x <> freeIn' y - freeIn' (SMod x y) = freeIn' x <> freeIn' y - freeIn' (SQuot x y) = freeIn' x <> freeIn' y - freeIn' (SRem x y) = freeIn' x <> freeIn' y - freeIn' (SLogOr x y) = freeIn' x <> freeIn' y - freeIn' (SLogAnd x y) = freeIn' x <> freeIn' y - freeIn' (RelExp LTH0 e) = freeIn' e - freeIn' (RelExp LEQ0 e) = freeIn' e - freeIn' (MaxMin _ es) = freeIn' es 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 @@ -7,15 +7,14 @@ , empty , fromScope , toScope + -- * Entries , Entry , deepen - , bindingDepth - , valueRange - , entryStm + , entryDepth , entryLetBoundDec - , entryType - , asScalExp + , entryIsSize + -- * Lookup , elem , lookup @@ -24,8 +23,8 @@ , lookupBasicOp , lookupType , lookupSubExp - , lookupScalExp , lookupAliases + , lookupLoopVar , available , consume , index @@ -33,33 +32,24 @@ , Indexed(..) , indexedAddCerts , IndexOp(..) + -- * Insertion , insertStm , insertStms , insertFParams , insertLParam - , insertArrayLParam , insertLoopVar - -- * Bounds - , updateBounds - , setUpperBound - , setLowerBound - , isAtLeast + -- * Misc - , rangesRep - , hideIf , hideCertified ) where import Control.Arrow ((&&&)) import Control.Monad -import Control.Monad.Reader import Data.Ord import Data.Maybe import Data.List (foldl', elemIndex) -import qualified Data.List as L -import qualified Data.Set as S import qualified Data.Map.Strict as M import Prelude hiding (elem, lookup) @@ -67,12 +57,7 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.IR hiding (FParam, lookupType) import qualified Futhark.IR as AST -import Futhark.Analysis.ScalExp -import qualified Futhark.Analysis.AlgSimplify as AS -import Futhark.IR.Prop.Ranges - (Range, ScalExpRange, Ranged) -import qualified Futhark.IR.Prop.Ranges as Ranges import qualified Futhark.IR.Prop.Aliases as Aliases data SymbolTable lore = SymbolTable { @@ -133,129 +118,72 @@ -- | Indexing a delayed array if possible. type IndexArray = [PrimExp VName] -> Maybe Indexed -data Entry lore = LoopVar (LoopVarEntry lore) - | LetBound (LetBoundEntry lore) - | FParam (FParamEntry lore) - | LParam (LParamEntry lore) - | FreeVar (FreeVarEntry lore) +data Entry lore = + Entry { entryConsumed :: Bool + -- ^ True if consumed. + , entryDepth :: Int + , entryIsSize :: Bool + -- ^ True if this name has been used as an array size, + -- implying that it is non-negative. + , entryType :: EntryType lore + } +data EntryType lore = LoopVar (LoopVarEntry lore) + | LetBound (LetBoundEntry lore) + | FParam (FParamEntry lore) + | LParam (LParamEntry lore) + | FreeVar (FreeVarEntry lore) + data LoopVarEntry lore = - LoopVarEntry { loopVarRange :: ScalExpRange - , loopVarStmDepth :: Int - , loopVarType :: IntType + LoopVarEntry { loopVarType :: IntType + , loopVarBound :: SubExp } data LetBoundEntry lore = - LetBoundEntry { letBoundRange :: ScalExpRange - , letBoundDec :: LetDec lore + LetBoundEntry { letBoundDec :: LetDec lore , letBoundAliases :: Names , letBoundStm :: Stm lore - , letBoundStmDepth :: Int - , letBoundScalExp :: Maybe ScalExp , letBoundIndex :: Int -> IndexArray -- ^ Index a delayed array, if possible. - , letBoundConsumed :: Bool - -- ^ True if consumed. } data FParamEntry lore = - FParamEntry { fparamRange :: ScalExpRange - , fparamDec :: FParamInfo lore + FParamEntry { fparamDec :: FParamInfo lore , fparamAliases :: Names - , fparamStmDepth :: Int - , fparamConsumed :: Bool } data LParamEntry lore = - LParamEntry { lparamRange :: ScalExpRange - , lparamDec :: LParamInfo lore - , lparamStmDepth :: Int + LParamEntry { lparamDec :: LParamInfo lore , lparamIndex :: IndexArray - , lparamConsumed :: Bool } data FreeVarEntry lore = FreeVarEntry { freeVarDec :: NameInfo lore - , freeVarStmDepth :: Int - , freeVarRange :: ScalExpRange , freeVarIndex :: VName -> IndexArray -- ^ Index a delayed array, if possible. - , freeVarConsumed :: Bool - -- ^ True if consumed. } -entryInfo :: Entry lore -> NameInfo lore -entryInfo (LetBound entry) = LetName $ letBoundDec entry -entryInfo (LoopVar entry) = IndexName $ loopVarType entry -entryInfo (FParam entry) = FParamName $ fparamDec entry -entryInfo (LParam entry) = LParamName $ lparamDec entry -entryInfo (FreeVar entry) = freeVarDec entry - -entryType :: ASTLore lore => Entry lore -> Type -entryType = typeOf . entryInfo - -isVarBound :: Entry lore -> Maybe (LetBoundEntry lore) -isVarBound (LetBound entry) = Just entry -isVarBound _ = Nothing - -asScalExp :: Entry lore -> Maybe ScalExp -asScalExp = letBoundScalExp <=< isVarBound - -bindingDepth :: Entry lore -> Int -bindingDepth (LetBound entry) = letBoundStmDepth entry -bindingDepth (FParam entry) = fparamStmDepth entry -bindingDepth (LParam entry) = lparamStmDepth entry -bindingDepth (LoopVar entry) = loopVarStmDepth entry -bindingDepth (FreeVar _) = 0 - -setStmDepth :: Int -> Entry lore -> Entry lore -setStmDepth d (LetBound entry) = - LetBound $ entry { letBoundStmDepth = d } -setStmDepth d (FParam entry) = - FParam $ entry { fparamStmDepth = d } -setStmDepth d (LParam entry) = - LParam $ entry { lparamStmDepth = d } -setStmDepth d (LoopVar entry) = - LoopVar $ entry { loopVarStmDepth = d } -setStmDepth d (FreeVar entry) = - FreeVar $ entry { freeVarStmDepth = d } - -valueRange :: Entry lore -> ScalExpRange -valueRange (LetBound entry) = letBoundRange entry -valueRange (FParam entry) = fparamRange entry -valueRange (LParam entry) = lparamRange entry -valueRange (LoopVar entry) = loopVarRange entry -valueRange (FreeVar entry) = freeVarRange entry +instance ASTLore lore => Typed (Entry lore) where + typeOf = typeOf . entryInfo -setValueRange :: ScalExpRange -> Entry lore -> Entry lore -setValueRange range (LetBound entry) = - LetBound $ entry { letBoundRange = range } -setValueRange range (FParam entry) = - FParam $ entry { fparamRange = range } -setValueRange range (LParam entry) = - LParam $ entry { lparamRange = range } -setValueRange range (LoopVar entry) = - LoopVar $ entry { loopVarRange = range } -setValueRange range (FreeVar entry) = - FreeVar $ entry { freeVarRange = range } +entryInfo :: Entry lore -> NameInfo lore +entryInfo e = case entryType e of + LetBound entry -> LetName $ letBoundDec entry + LoopVar entry -> IndexName $ loopVarType entry + FParam entry -> FParamName $ fparamDec entry + LParam entry -> LParamName $ lparamDec entry + FreeVar entry -> freeVarDec entry -consumed :: Entry lore -> Bool -consumed (LetBound entry) = letBoundConsumed entry -consumed (FParam entry) = fparamConsumed entry -consumed (LParam entry) = lparamConsumed entry -consumed LoopVar{} = False -consumed (FreeVar entry) = freeVarConsumed entry +isLetBound :: Entry lore -> Maybe (LetBoundEntry lore) +isLetBound e = case entryType e of + LetBound entry -> Just entry + _ -> Nothing entryStm :: Entry lore -> Maybe (Stm lore) -entryStm (LetBound entry) = Just $ letBoundStm entry -entryStm _ = Nothing +entryStm = fmap letBoundStm . isLetBound entryLetBoundDec :: Entry lore -> Maybe (LetDec lore) -entryLetBoundDec (LetBound entry) = Just $ letBoundDec entry -entryLetBoundDec _ = Nothing - -asStm :: Entry lore -> Maybe (Stm lore) -asStm = fmap letBoundStm . isVarBound +entryLetBoundDec = fmap letBoundDec . isLetBound elem :: VName -> SymbolTable lore -> Bool elem name = isJust . lookup name @@ -264,7 +192,7 @@ lookup name = M.lookup name . bindings lookupStm :: VName -> SymbolTable lore -> Maybe (Stm lore) -lookupStm name vtable = asStm =<< lookup name vtable +lookupStm name vtable = entryStm =<< lookup name vtable lookupExp :: VName -> SymbolTable lore -> Maybe (Exp lore, Certificates) lookupExp name vtable = (stmExp &&& stmCerts) <$> lookupStm name vtable @@ -275,7 +203,7 @@ _ -> Nothing lookupType :: ASTLore lore => VName -> SymbolTable lore -> Maybe Type -lookupType name vtable = entryType <$> lookup name vtable +lookupType name vtable = typeOf <$> lookup name vtable lookupSubExpType :: ASTLore lore => SubExp -> SymbolTable lore -> Maybe Type lookupSubExpType (Var v) = lookupType v @@ -288,28 +216,23 @@ BasicOp (SubExp se) -> Just (se,cs) _ -> Nothing -lookupScalExp :: ASTLore lore => VName -> SymbolTable lore -> Maybe ScalExp -lookupScalExp name vtable = - case (lookup name vtable, lookupRange name vtable) of - -- If we know the lower and upper bound, and these are the same, - -- then we morally know the ScalExp, but only if the variable has - -- the right type. - (Just entry, (Just lower, Just upper)) - | entryType entry == Prim int32, - lower == upper, scalExpType lower == int32 -> - Just $ expandScalExp (`lookupScalExp` vtable) lower - (Just entry, _) -> asScalExp entry - _ -> Nothing - lookupAliases :: VName -> SymbolTable lore -> Names -lookupAliases name vtable = case M.lookup name $ bindings vtable of - Just (LetBound e) -> letBoundAliases e - Just (FParam e) -> fparamAliases e - _ -> mempty +lookupAliases name vtable = + case entryType <$> M.lookup name (bindings vtable) of + Just (LetBound e) -> letBoundAliases e + Just (FParam e) -> fparamAliases e + _ -> mempty +-- | If the given variable name is the name of a 'ForLoop' parameter, +-- then return the bound of that loop. +lookupLoopVar :: VName -> SymbolTable lore -> Maybe SubExp +lookupLoopVar name vtable = do + LoopVar e <- entryType <$> M.lookup name (bindings vtable) + return $ loopVarBound e + -- | In symbol table and not consumed. available :: VName -> SymbolTable lore -> Bool -available name = maybe False (not . consumed) . M.lookup name . bindings +available name = maybe False (not . entryConsumed) . M.lookup name . bindings index :: ASTLore lore => VName -> [SubExp] -> SymbolTable lore -> Maybe Indexed @@ -324,7 +247,7 @@ -> Maybe Indexed index' name is vtable = do entry <- lookup name vtable - case entry of + case entryType entry of LetBound entry' | Just k <- elemIndex name $ patternValueNames $ stmPattern $ letBoundStm entry' -> @@ -334,16 +257,6 @@ LParam entry' -> lparamIndex entry' is _ -> Nothing -lookupRange :: VName -> SymbolTable lore -> ScalExpRange -lookupRange name vtable = - maybe (Nothing, Nothing) valueRange $ lookup name vtable - -rangesRep :: SymbolTable lore -> AS.RangesRep -rangesRep = M.filter knownRange . M.map toRep . bindings - where toRep entry = (bindingDepth entry, lower, upper) - where (lower, upper) = valueRange entry - knownRange (_, lower, upper) = isJust lower || isJust upper - class IndexOp op where indexOp :: (ASTLore lore, IndexOp (Op lore)) => SymbolTable lore -> Int -> op @@ -398,85 +311,50 @@ defBndEntry :: (ASTLore lore, IndexOp (Op lore)) => SymbolTable lore -> PatElem lore - -> Range -> Names -> Stm lore -> LetBoundEntry lore -defBndEntry vtable patElem range als bnd = +defBndEntry vtable patElem als bnd = LetBoundEntry { - letBoundRange = simplifyRange $ scalExpRange range - , letBoundDec = patElemDec patElem + letBoundDec = patElemDec patElem , letBoundAliases = als , letBoundStm = bnd - , letBoundScalExp = - runReader (toScalExp (`lookupScalExp` vtable) (stmExp bnd)) types - , letBoundStmDepth = 0 , letBoundIndex = \k -> fmap (indexedAddCerts (stmAuxCerts $ stmAux bnd)) . indexExp vtable (stmExp bnd) k - , letBoundConsumed = False } - where ranges :: AS.RangesRep - ranges = rangesRep vtable - types = toScope vtable - - scalExpRange :: Range -> ScalExpRange - scalExpRange (lower, upper) = - (scalExpBound fst =<< lower, - scalExpBound snd =<< upper) - - scalExpBound :: (ScalExpRange -> Maybe ScalExp) - -> Ranges.KnownBound - -> Maybe ScalExp - scalExpBound pick (Ranges.VarBound v) = - pick $ lookupRange v vtable - scalExpBound _ (Ranges.ScalarBound se) = - Just se - scalExpBound _ (Ranges.MinimumBound b1 b2) = do - b1' <- scalExpBound fst b1 - b2' <- scalExpBound fst b2 - return $ MaxMin True [b1', b2'] - scalExpBound _ (Ranges.MaximumBound b1 b2) = do - b1' <- scalExpBound snd b1 - b2' <- scalExpBound snd b2 - return $ MaxMin False [b1', b2'] - - simplifyRange :: ScalExpRange -> ScalExpRange - simplifyRange (lower, upper) = - (simplifyBound lower, - simplifyBound upper) - - simplifyBound (Just se) | scalExpType se == int32 = - Just $ AS.simplify se ranges - simplifyBound _ = - Nothing - -bindingEntries :: (Ranged lore, Aliases.Aliased lore, IndexOp (Op lore)) => +bindingEntries :: (ASTLore lore, Aliases.Aliased lore, IndexOp (Op lore)) => Stm lore -> SymbolTable lore -> [LetBoundEntry lore] bindingEntries bnd@(Let pat _ _) vtable = do pat_elem <- patternElements pat - return $ defBndEntry vtable pat_elem - (Ranges.rangeOf pat_elem) (Aliases.aliasesOf pat_elem) bnd + return $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) bnd +adjustSeveral :: Ord k => (v -> v) -> [k] -> M.Map k v -> M.Map k v +adjustSeveral f = flip $ foldl' $ flip $ M.adjust f + insertEntry :: ASTLore lore => - VName -> Entry lore -> SymbolTable lore + VName -> EntryType lore -> SymbolTable lore -> SymbolTable lore -insertEntry name entry = - insertEntries [(name,entry)] +insertEntry name entry vtable = + let entry' = Entry { entryConsumed = False + , entryDepth = loopDepth vtable + , entryIsSize = False + , entryType = entry + } + dims = mapMaybe subExpVar $ arrayDims $ typeOf entry' + isSize e = e { entryIsSize = True } + in vtable { bindings = adjustSeveral isSize dims $ + M.insert name entry' $ bindings vtable } insertEntries :: ASTLore lore => - [(VName, Entry lore)] -> SymbolTable lore + [(VName, EntryType lore)] -> SymbolTable lore -> SymbolTable lore insertEntries entries vtable = - let vtable' = vtable { bindings = foldl insertWithDepth (bindings vtable) entries } - in foldr (`isAtLeast` 0) vtable' dim_vars - where insertWithDepth bnds (name, entry) = - let entry' = setStmDepth (loopDepth vtable) entry - in M.insert name entry' bnds - dim_vars = subExpVars $ concatMap (arrayDims . entryType . snd) entries + foldl' add vtable entries + where add vtable' (name, entry) = insertEntry name entry vtable' -insertStm :: (IndexOp (Op lore), Ranged lore, Aliases.Aliased lore) => +insertStm :: (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) => Stm lore -> SymbolTable lore -> SymbolTable lore @@ -485,23 +363,21 @@ flip (foldl' addRevAliases) (patternElements $ stmPattern stm) $ insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable where names = patternNames $ stmPattern stm - adjustSeveral f = flip $ foldl' $ flip $ M.adjust f stm_consumed = expandAliases (Aliases.consumedInStm stm) vtable addRevAliases vtable' pe = vtable' { bindings = adjustSeveral update inedges $ bindings vtable' } where inedges = namesToList $ expandAliases (Aliases.aliasesOf pe) vtable' - update (LetBound entry) = + update e = e { entryType = update' $ entryType e } + update' (LetBound entry) = LetBound entry { letBoundAliases = oneName (patElemName pe) <> letBoundAliases entry } - update (FParam entry) = + update' (FParam entry) = FParam entry { fparamAliases = oneName (patElemName pe) <> fparamAliases entry } - update e = e + update' e = e -insertStms :: (IndexOp (Op lore), Ranged lore, Aliases.Aliased lore) => - Stms lore - -> SymbolTable lore - -> SymbolTable lore +insertStms :: (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) => + Stms lore -> SymbolTable lore -> SymbolTable lore insertStms stms vtable = foldl' (flip insertStm) vtable $ stmsToList stms expandAliases :: Names -> SymbolTable lore -> Names @@ -510,237 +386,54 @@ mconcat . map (`lookupAliases` vtable) . namesToList $ names insertFParam :: ASTLore lore => - AST.FParam lore - -> SymbolTable lore - -> SymbolTable lore -insertFParam fparam = flip (foldr (`isAtLeast` 0)) sizes . insertEntry name entry + AST.FParam lore -> SymbolTable lore -> SymbolTable lore +insertFParam fparam = insertEntry name entry where name = AST.paramName fparam - entry = FParam FParamEntry { fparamRange = (Nothing, Nothing) - , fparamDec = AST.paramDec fparam + entry = FParam FParamEntry { fparamDec = AST.paramDec fparam , fparamAliases = mempty - , fparamStmDepth = 0 - , fparamConsumed = False } - sizes = subExpVars $ arrayDims $ AST.paramType fparam insertFParams :: ASTLore lore => - [AST.FParam lore] - -> SymbolTable lore - -> SymbolTable lore + [AST.FParam lore] -> SymbolTable lore -> SymbolTable lore insertFParams fparams symtable = foldl' (flip insertFParam) symtable fparams -insertLParamWithRange :: ASTLore lore => - LParam lore -> ScalExpRange -> IndexArray -> SymbolTable lore - -> SymbolTable lore -insertLParamWithRange param range indexf vtable = - -- We know that the sizes in the type of param are at least zero, - -- since they are array sizes. - let vtable' = insertEntry name bind vtable - in foldr (`isAtLeast` 0) vtable' sizevars - where bind = LParam LParamEntry { lparamRange = range - , lparamDec = AST.paramDec param - , lparamStmDepth = 0 - , lparamIndex = indexf - , lparamConsumed = False +insertLParam :: ASTLore lore => LParam lore -> SymbolTable lore -> SymbolTable lore +insertLParam param = insertEntry name bind + where bind = LParam LParamEntry { lparamDec = AST.paramDec param + , lparamIndex = const Nothing } name = AST.paramName param - sizevars = subExpVars $ arrayDims $ AST.paramType param -insertLParam :: ASTLore lore => - LParam lore -> SymbolTable lore -> SymbolTable lore -insertLParam param = - insertLParamWithRange param (Nothing, Nothing) (const Nothing) - -insertArrayLParam :: ASTLore lore => - LParam lore -> Maybe VName -> SymbolTable lore - -> SymbolTable lore -insertArrayLParam param (Just array) vtable = - -- We now know that the outer size of 'array' is at least one, and - -- that the inner sizes are at least zero, since they are array - -- sizes. - let vtable' = insertLParamWithRange param (lookupRange array vtable) (const Nothing) vtable - in case arrayDims <$> lookupType array vtable of - Just (Var v:_) -> (v `isAtLeast` 1) vtable' - _ -> vtable' -insertArrayLParam param Nothing vtable = - -- Well, we still know that it's a param... - insertLParam param vtable - insertLoopVar :: ASTLore lore => VName -> IntType -> SubExp -> SymbolTable lore -> SymbolTable lore insertLoopVar name it bound = insertEntry name bind where bind = LoopVar LoopVarEntry { - loopVarRange = (Just 0, - Just $ subExpToScalExp bound (IntType it) - 1) - , loopVarStmDepth = 0 - , loopVarType = it + loopVarType = it + , loopVarBound = bound } insertFreeVar :: ASTLore lore => VName -> NameInfo lore -> SymbolTable lore -> SymbolTable lore insertFreeVar name dec = insertEntry name entry where entry = FreeVar FreeVarEntry { freeVarDec = dec - , freeVarRange = (Nothing, Nothing) - , freeVarStmDepth = 0 , freeVarIndex = \_ _ -> Nothing - , freeVarConsumed = False } -updateBounds :: ASTLore lore => Bool -> SubExp -> SymbolTable lore -> SymbolTable lore -updateBounds isTrue cond vtable = - case runReader (toScalExp (`lookupScalExp` vtable) $ BasicOp $ SubExp cond) types of - Nothing -> vtable - Just cond' -> - let cond'' | isTrue = cond' - | otherwise = SNot cond' - in updateBounds' cond'' vtable - where types = toScope vtable - --- | Updating the ranges of all symbols whenever we enter a branch is --- presently too expensive, and disabled here. -noUpdateBounds :: Bool -noUpdateBounds = True - --- | Refines the ranges in the symbol table with --- ranges extracted from branch conditions. --- @cond@ is the condition of the if-branch. -updateBounds' :: ScalExp -> SymbolTable lore -> SymbolTable lore -updateBounds' _ sym_tab | noUpdateBounds = sym_tab -updateBounds' cond sym_tab = - foldr updateBound sym_tab $ mapMaybe solve_leq0 $ - getNotFactorsLEQ0 $ AS.simplify (SNot cond) ranges - where - updateBound (sym,True ,bound) = setUpperBound sym bound - updateBound (sym,False,bound) = setLowerBound sym bound - - ranges = M.filter nonEmptyRange $ M.map toRep $ bindings sym_tab - toRep entry = (bindingDepth entry, lower, upper) - where (lower, upper) = valueRange entry - nonEmptyRange (_, lower, upper) = isJust lower || isJust upper - - -- | Input: a bool exp in DNF form, named @cond@ - -- It gets the terms of the argument, - -- i.e., cond = c1 || ... || cn - -- and negates them. - -- Returns [not c1, ..., not cn], i.e., the factors - -- of @not cond@ in CNF form: not cond = (not c1) && ... && (not cn) - getNotFactorsLEQ0 :: ScalExp -> [ScalExp] - getNotFactorsLEQ0 (RelExp rel e_scal) = - if scalExpType e_scal /= int32 then [] - else let leq0_escal = if rel == LTH0 - then SMinus 0 e_scal - else SMinus 1 e_scal - - in [AS.simplify leq0_escal ranges] - getNotFactorsLEQ0 (SLogOr e1 e2) = getNotFactorsLEQ0 e1 ++ getNotFactorsLEQ0 e2 - getNotFactorsLEQ0 _ = [] - - -- | Argument is scalar expression @e@. - -- Implementation finds the symbol defined at - -- the highest depth in expression @e@, call it @i@, - -- and decomposes e = a*i + b. If @a@ and @b@ are - -- free of @i@, AND @a == 1 or -1@ THEN the upper/lower - -- bound can be improved. Otherwise Nothing. - -- - -- Returns: Nothing or - -- Just (i, a == 1, -a*b), i.e., (symbol, isUpperBound, bound) - solve_leq0 :: ScalExp -> Maybe (VName, Bool, ScalExp) - solve_leq0 e_scal = do - sym <- pickRefinedSym S.empty e_scal - (a,b) <- either (const Nothing) id $ AS.linFormScalE sym e_scal ranges - case a of - -1 -> - Just (sym, False, b) - 1 -> - let mb = AS.simplify (negate b) ranges - in Just (sym, True, mb) - _ -> Nothing - - -- When picking a symbols, @sym@ whose bound it is to be refined: - -- make sure that @sym@ does not belong to the transitive closure - -- of the symbols apearing in the ranges of all the other symbols - -- in the sclar expression (themselves included). - -- If this does not hold, pick another symbol, rinse and repeat. - pickRefinedSym :: S.Set VName -> ScalExp -> Maybe VName - pickRefinedSym elsyms0 e_scal = do - let candidates = freeIn e_scal - sym0 = AS.pickSymToElim ranges elsyms0 e_scal - case sym0 of - Just sy -> let trclsyms = foldl trClSymsInRange mempty $ namesToList $ - candidates `namesSubtract` oneName sy - in if sy `nameIn` trclsyms - then pickRefinedSym (S.insert sy elsyms0) e_scal - else sym0 - Nothing -> sym0 - - -- computes the transitive closure of the symbols appearing - -- in the ranges of a symbol - trClSymsInRange :: Names -> VName -> Names - trClSymsInRange cur_syms sym = - if sym `nameIn` cur_syms then cur_syms - else case M.lookup sym ranges of - Just (_,lb,ub) -> let sym_bds = concatMap (namesToList . freeIn) (catMaybes [lb, ub]) - in foldl trClSymsInRange - (oneName sym <> cur_syms) - sym_bds - Nothing -> oneName sym <> cur_syms - -consume :: ASTLore lore => VName -> SymbolTable lore -> SymbolTable lore +consume :: VName -> SymbolTable lore -> SymbolTable lore consume consumee vtable = foldl' consume' vtable $ namesToList $ expandAliases (oneName consumee) vtable - where consume' vtable' v | Just e <- lookup v vtable = insertEntry v (consume'' e) vtable' - | otherwise = vtable' - consume'' (FreeVar e) = FreeVar e { freeVarConsumed = True } - consume'' (LetBound e) = LetBound e { letBoundConsumed = True } - consume'' (FParam e) = FParam e { fparamConsumed = True } - consume'' (LParam e) = LParam e { lparamConsumed = True } - consume'' (LoopVar e) = LoopVar e - -setUpperBound :: VName -> ScalExp -> SymbolTable lore - -> SymbolTable lore -setUpperBound name bound vtable = - vtable { bindings = M.adjust setUpperBound' name $ bindings vtable } - where setUpperBound' entry = - let (oldLowerBound, oldUpperBound) = valueRange entry - in if alreadyTheBound bound True oldUpperBound - then entry - else setValueRange - (oldLowerBound, - Just $ maybe bound (MaxMin True . (:[bound])) oldUpperBound) - entry - -setLowerBound :: VName -> ScalExp -> SymbolTable lore -> SymbolTable lore -setLowerBound name bound vtable = - vtable { bindings = M.adjust setLowerBound' name $ bindings vtable } - where setLowerBound' entry = - let (oldLowerBound, oldUpperBound) = valueRange entry - in if alreadyTheBound bound False oldLowerBound - then entry - else setValueRange - (Just $ maybe bound (MaxMin False . (:[bound])) oldLowerBound, - oldUpperBound) - entry - -alreadyTheBound :: ScalExp -> Bool -> Maybe ScalExp -> Bool -alreadyTheBound _ _ Nothing = False -alreadyTheBound new_bound b1 (Just cur_bound) - | cur_bound == new_bound = True - | MaxMin b2 ses <- cur_bound = b1 == b2 && (new_bound `L.elem` ses) - | otherwise = False - -isAtLeast :: VName -> Int -> SymbolTable lore -> SymbolTable lore -isAtLeast name x = - setLowerBound name $ fromIntegral x + where consume' vtable' v = + vtable' { bindings = M.adjust consume'' v $ bindings vtable' } + consume'' e = e { entryConsumed = True } -- | Hide definitions of those entries that satisfy some predicate. hideIf :: (Entry lore -> Bool) -> SymbolTable lore -> SymbolTable lore hideIf hide vtable = vtable { bindings = M.map maybeHide $ bindings vtable } where maybeHide entry - | hide entry = FreeVar FreeVarEntry { freeVarDec = entryInfo entry - , freeVarStmDepth = bindingDepth entry - , freeVarRange = valueRange entry - , freeVarIndex = \_ _ -> Nothing - , freeVarConsumed = consumed entry - } + | hide entry = entry { entryType = + FreeVar FreeVarEntry { freeVarDec = entryInfo entry + , freeVarIndex = \_ _ -> Nothing + } + } | otherwise = entry -- | Hide these definitions, if they are protected by certificates in diff --git a/src/Futhark/Analysis/UsageTable.hs b/src/Futhark/Analysis/UsageTable.hs --- a/src/Futhark/Analysis/UsageTable.hs +++ b/src/Futhark/Analysis/UsageTable.hs @@ -10,10 +10,13 @@ , isConsumed , isInResult , isUsedDirectly + , isSize , usages , usage , consumedUsage , inResultUsage + , sizeUsage + , sizeUsages , Usages , usageInStm ) @@ -21,8 +24,8 @@ import Data.Bits import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Strict as IM import Data.List (foldl') -import qualified Data.Map.Strict as M import Prelude hiding (lookup) @@ -30,23 +33,24 @@ import Futhark.IR.Prop.Aliases -- | A usage table. -newtype UsageTable = UsageTable (M.Map VName Usages) +newtype UsageTable = UsageTable (IM.IntMap Usages) deriving (Eq, Show) instance Semigroup UsageTable where UsageTable table1 <> UsageTable table2 = - UsageTable $ M.unionWith (<>) table1 table2 + UsageTable $ IM.unionWith (<>) table1 table2 instance Monoid UsageTable where mempty = UsageTable mempty -- | Remove these entries from the usage table. without :: UsageTable -> [VName] -> UsageTable -without (UsageTable table) = UsageTable . Foldable.foldl (flip M.delete) table +without (UsageTable table) = + UsageTable . Foldable.foldl (flip IM.delete) table . map baseTag -- | Look up a variable in the usage table. lookup :: VName -> UsageTable -> Maybe Usages -lookup name (UsageTable table) = M.lookup name table +lookup name (UsageTable table) = IM.lookup (baseTag name) table lookupPred :: (Usages -> Bool) -> VName -> UsageTable -> Bool lookupPred f name = maybe False f . lookup name @@ -57,10 +61,10 @@ -- | Expand the usage table based on aliasing information. expand :: (VName -> Names) -> UsageTable -> UsageTable -expand look (UsageTable m) = UsageTable $ foldl' grow m $ M.toList m +expand look (UsageTable m) = UsageTable $ foldl' grow m $ IM.toList m where grow m' (k, v) = foldl' (grow'' $ v `withoutU` presentU) m' $ - namesToList $ look k - grow'' v m'' k = M.insertWith (<>) k v m'' + namesIntMap $ look $ VName (nameFromString "") k + grow'' v m'' k = IM.insertWith (<>) (baseTag k) v m'' is :: Usages -> VName -> UsageTable -> Bool is = lookupPred . matches @@ -78,25 +82,39 @@ isUsedDirectly :: VName -> UsageTable -> Bool isUsedDirectly = is presentU +-- | Is this name used as the size of something (array or memory block)? +isSize :: VName -> UsageTable -> Bool +isSize = is sizeU + -- | Construct a usage table reflecting that these variables have been -- used. usages :: Names -> UsageTable -usages names = UsageTable $ M.fromList [ (name, presentU) | name <- namesToList names ] +usages = UsageTable . IM.map (const presentU) . namesIntMap -- | Construct a usage table where the given variable has been used in -- this specific way. usage :: VName -> Usages -> UsageTable -usage name uses = UsageTable $ M.singleton name uses +usage name uses = UsageTable $ IM.singleton (baseTag name) uses -- | Construct a usage table where the given variable has been consumed. consumedUsage :: VName -> UsageTable -consumedUsage name = UsageTable $ M.singleton name consumedU +consumedUsage name = UsageTable $ IM.singleton (baseTag name) consumedU -- | Construct a usage table where the given variable has been used in -- the 'Result' of a body. inResultUsage :: VName -> UsageTable -inResultUsage name = UsageTable $ M.singleton name inResultU +inResultUsage name = UsageTable $ IM.singleton (baseTag name) inResultU +-- | Construct a usage table where the given variable has been used as +-- an array or memory size. +sizeUsage :: VName -> UsageTable +sizeUsage name = UsageTable $ IM.singleton (baseTag name) sizeU + +-- | Construct a usage table where the given names have been used as +-- an array or memory size. +sizeUsages :: Names -> UsageTable +sizeUsages = UsageTable . IM.map (const sizeU) . namesIntMap + -- | A description of how a single variable has been used. newtype Usages = Usages Int -- Bitmap representation for speed. deriving (Eq, Ord, Show) @@ -107,10 +125,11 @@ instance Monoid Usages where mempty = Usages 0 -consumedU, inResultU, presentU :: Usages +consumedU, inResultU, presentU, sizeU :: Usages consumedU = Usages 1 inResultU = Usages 2 presentU = Usages 4 +sizeU = Usages 8 -- | Check whether the bits that are set in the first argument are -- also set in the second. @@ -131,8 +150,9 @@ usages (freeIn e)] where usageInPat = usages (mconcat (map freeIn $ patternElements pat) - `namesSubtract` - namesFromList (patternNames pat)) + `namesSubtract` + namesFromList (patternNames pat)) <> + sizeUsages (foldMap (freeIn . patElemType) (patternElements pat)) usageInExpLore = usages $ freeIn lore diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -20,6 +20,7 @@ where import Control.Applicative +import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad.Except import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS @@ -31,6 +32,7 @@ import System.FilePath import System.Exit import System.IO +import System.IO.Error import System.IO.Temp (withSystemTempFile) import System.Process.ByteString (readProcessWithExitCode) import System.Timeout (timeout) @@ -163,8 +165,34 @@ , runExtraOptions :: [String] , runTimeout :: Int , runVerbose :: Int + , runResultAction :: Maybe (Int -> IO ()) + -- ^ Invoked for every runtime measured during the run. Can be + -- used to provide a progress bar. } + +-- | 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 + + triesPerSecond = 10 + followDelayMicroseconds = 1000000 `div` triesPerSecond + -- | Run the benchmark program on the indicated dataset. benchmarkDataset :: RunOptions -> FilePath -> T.Text -> Values -> Maybe Success -> FilePath @@ -197,10 +225,20 @@ putStrLn $ unwords ["Running executable", show to_run, "with arguments", show to_run_args] + let onResult l + | Just f <- runResultAction opts, + [(x, "")] <- reads l = + f x + | otherwise = + pure () + watcher <- forkIO $ follow onResult tmpfile + run_res <- timeout (runTimeout opts * 1000000) $ readProcessWithExitCode to_run to_run_args $ LBS.toStrict input + + killThread watcher runExceptT $ case run_res of Just (progCode, output, progerr) -> do diff --git a/src/Futhark/Binder.hs b/src/Futhark/Binder.hs --- a/src/Futhark/Binder.hs +++ b/src/Futhark/Binder.hs @@ -3,7 +3,11 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} -- | This module defines a convenience monad/typeclass for creating --- normalised programs. +-- normalised programs. The fundamental building block is 'BinderT' +-- and its execution functions, but it is usually easier to use +-- 'Binder'. +-- +-- See "Futhark.Construct" for a high-level description. module Futhark.Binder ( -- * A concrete @MonadBinder@ monad. BinderT @@ -13,11 +17,8 @@ , Binder , runBinder , runBinder_ - , joinBinder , runBodyBinder - -- * Non-class interface - , addBinderStms - , collectBinderStms + -- * The 'MonadBinder' typeclass , module Futhark.Binder.Class ) @@ -33,10 +34,12 @@ import Futhark.Binder.Class import Futhark.IR +-- | A 'BinderT' (and by extension, a 'Binder') is only an instance of +-- 'MonadBinder' for lores that implement this type class, which +-- contains methods for constructing statements. class ASTLore lore => BinderOps lore where mkExpDecB :: (MonadBinder m, Lore m ~ lore) => Pattern lore -> Exp lore -> m (ExpDec lore) - mkBodyB :: (MonadBinder m, Lore m ~ lore) => Stms lore -> Result -> m (Body lore) mkLetNamesB :: (MonadBinder m, Lore m ~ lore) => @@ -54,12 +57,19 @@ [VName] -> Exp lore -> m (Stm lore) mkLetNamesB = mkLetNames +-- | A monad transformer that tracks statements and provides a +-- 'MonadBinder' instance, assuming that the underlying monad provides +-- a name source. In almost all cases, this is what you will use for +-- constructing statements (possibly as part of a larger monad stack). +-- If you find yourself needing to implement 'MonadBinder' from +-- scratch, then it is likely that you are making a mistake. newtype BinderT lore m a = BinderT (StateT (Stms lore, Scope lore) m a) deriving (Functor, Monad, Applicative) instance MonadTrans (BinderT lore) where lift = BinderT . lift +-- | The most commonly used binder monad. type Binder lore = BinderT lore (State VNameSource) instance MonadFreshNames m => MonadFreshNames (BinderT lore m) where @@ -90,9 +100,20 @@ mkBodyM = mkBodyB mkLetNamesM = mkLetNamesB - addStms = addBinderStms - collectStms = collectBinderStms + addStms stms = + BinderT $ modify $ \(cur_stms,scope) -> + (cur_stms<>stms, scope `M.union` scopeOf stms) + collectStms m = do + (old_stms, old_scope) <- BinderT get + BinderT $ put (mempty, old_scope) + x <- m + (new_stms, _) <- BinderT get + BinderT $ put (old_stms, old_scope) + return (x, new_stms) + +-- | Run a binder action given an initial scope, returning a value and +-- the statements added ('addStm') during the action. runBinderT :: MonadFreshNames m => BinderT lore m a -> Scope lore @@ -101,10 +122,13 @@ (x, (stms, _)) <- runStateT m (mempty, scope) return (x, stms) +-- | Like 'runBinderT', but return only the statements. runBinderT_ :: MonadFreshNames m => - BinderT lore m a -> Scope lore -> m (Stms lore) + BinderT lore m () -> Scope lore -> m (Stms lore) runBinderT_ m = fmap snd . runBinderT m +-- | Like 'runBinderT', but get the initial scope from the current +-- monad. runBinderT' :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) => BinderT lore m a -> m (a, Stms lore) @@ -112,10 +136,15 @@ scope <- askScope runBinderT m $ castScope scope +-- | Like 'runBinderT_', but get the initial scope from the current +-- monad. runBinderT'_ :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) => BinderT lore m a -> m (Stms lore) runBinderT'_ = fmap snd . runBinderT' +-- | Run a binder action, returning a value and the statements added +-- ('addStm') during the action. Assumes that the current monad +-- provides initial scope and name source. runBinder :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) => Binder lore a @@ -125,41 +154,19 @@ modifyNameSource $ runState $ runBinderT m $ castScope types -- | Like 'runBinder', but throw away the result and just return the --- added bindings. +-- added statements. runBinder_ :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) => Binder lore a -> m (Stms lore) runBinder_ = fmap snd . runBinder --- | As 'runBinder', but uses 'addStm' to add the returned --- bindings to the surrounding monad. -joinBinder :: MonadBinder m => Binder (Lore m) a -> m a -joinBinder m = do (x, bnds) <- runBinder m - addStms bnds - return x - +-- | Run a binder that produces a t'Body', and prefix that t'Body' by +-- the statements produced during execution of the action. runBodyBinder :: (Bindable lore, MonadFreshNames m, HasScope somelore m, SameScope somelore lore) => Binder lore (Body lore) -> m (Body lore) runBodyBinder = fmap (uncurry $ flip insertStms) . runBinder - -addBinderStms :: Monad m => - Stms lore -> BinderT lore m () -addBinderStms stms = BinderT $ - modify $ \(cur_stms,scope) -> (cur_stms<>stms, - scope `M.union` scopeOf stms) - -collectBinderStms :: Monad m => - BinderT lore m a - -> BinderT lore m (a, Stms lore) -collectBinderStms m = do - (old_stms, old_scope) <- BinderT get - BinderT $ put (mempty, old_scope) - x <- m - (new_stms, _) <- BinderT get - BinderT $ put (old_stms, old_scope) - return (x, new_stms) -- Utility instance defintions for MTL classes. These require -- UndecidableInstances, but save on typing elsewhere. diff --git a/src/Futhark/Binder/Class.hs b/src/Futhark/Binder/Class.hs --- a/src/Futhark/Binder/Class.hs +++ b/src/Futhark/Binder/Class.hs @@ -1,9 +1,12 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies #-} -- | This module defines a convenience typeclass for creating -- normalised programs. +-- +-- See "Futhark.Construct" for a high-level description. module Futhark.Binder.Class ( Bindable (..) , mkLet + , mkLet' , MonadBinder (..) , insertStms , insertStm @@ -116,6 +119,14 @@ let pat = mkExpPat ctx val e dec = mkExpDec pat e in Let pat (defAux dec) e + +-- | Like mkLet, but also take attributes and certificates from the +-- given 'StmAux'. +mkLet' :: Bindable lore => [Ident] -> [Ident] -> StmAux a -> Exp lore -> Stm lore +mkLet' ctx val (StmAux cs attrs _) e = + let pat = mkExpPat ctx val e + dec = mkExpDec pat e + in Let pat (StmAux cs attrs dec) e -- | Add a statement with the given pattern element names and -- expression. 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 @@ -22,6 +22,7 @@ import Futhark.Bench import Futhark.Test +import Futhark.Util (maxinum) import Futhark.Util.Options data AutotuneOptions = AutotuneOptions @@ -32,11 +33,12 @@ , optExtraOptions :: [String] , optVerbose :: Int , optTimeout :: Int + , optDefaultThreshold :: Int } initialAutotuneOptions :: AutotuneOptions initialAutotuneOptions = - AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0 60 + AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0 60 thresholdMax compileOptions :: AutotuneOptions -> IO CompileOptions compileOptions opts = do @@ -50,9 +52,14 @@ runOptions path timeout_s opts = RunOptions { runRunner = "" , runRuns = optRuns opts - , runExtraOptions = "-L" : map opt path ++ optExtraOptions opts + , runExtraOptions = "--default-threshold" : + show (optDefaultThreshold opts) : + "-L" : + map opt path ++ + optExtraOptions opts , runTimeout = timeout_s , runVerbose = optVerbose opts + , runResultAction = Nothing } where opt (name, val) = "--size=" ++ name ++ "=" ++ show val @@ -242,7 +249,7 @@ newMax <- binarySearch runner (t, tMax) ePars let newMinIdx = pred <$> elemIndex newMax ePars - let newMin = maximum $ catMaybes [Just tMin, newMinIdx] + let newMin = maxinum $ catMaybes [Just tMin, newMinIdx] return (newMin, newMax) bestPair :: [(Int, Int)] -> (Int, Int) 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 @@ -9,10 +9,12 @@ import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Either +import Data.IORef import Data.Maybe import Data.List (foldl', sortBy) import Data.Ord import qualified Data.Text as T +import System.Console.ANSI (clearLine) import System.Console.GetOpt import System.Directory import System.Environment @@ -23,7 +25,7 @@ import Futhark.Bench import Futhark.Test -import Futhark.Util (pmapIO) +import Futhark.Util (fancyTerminal, maybeNth, maxinum, pmapIO) import Futhark.Util.Console import Futhark.Util.Options @@ -150,23 +152,57 @@ pad_to = foldl max 0 $ concatMap (map (length . runDescription) . iosTestRuns) cases +runOptions :: (Int -> IO ()) -> BenchOptions -> RunOptions +runOptions f opts = + RunOptions { runRunner = optRunner opts + , runRuns = optRuns opts + , runExtraOptions = optExtraOptions opts + , runTimeout = optTimeout opts + , runVerbose = optVerbose opts + , runResultAction = Just f + } + +progressBar :: Int -> Int -> Int -> String +progressBar cur bound steps = + "[" ++ map cell [1..steps] ++ "] " ++ show cur ++ "/" ++ show bound + where step_size = bound `div` steps + chars = " ▏▎▍▍▌▋▊▉█" + char i = fromMaybe ' ' $ maybeNth (i::Int) chars + + cell :: Int -> Char + cell i + | i * step_size <= cur = char 9 + | otherwise = char (((cur - (i-1) * step_size) * length chars) + `div` step_size) + +descString :: String -> Int -> String +descString desc pad_to = desc ++ ": " ++ replicate (pad_to - length desc) ' ' + +mkProgressPrompt :: Int -> Int -> String -> IO (Maybe Int -> IO ()) +mkProgressPrompt runs pad_to dataset_desc + | fancyTerminal = do + count <- newIORef (0::Int) + return $ \us -> do + putStr "\r" -- Go to start of line. + i <- readIORef count + let i' = if isJust us then i+1 else i + writeIORef count i' + putStr $ descString dataset_desc pad_to ++ progressBar i' runs 10 + putStr " " -- Just to move the cursor away from the progress bar. + hFlush stdout + + | otherwise = do + putStr $ descString dataset_desc pad_to + hFlush stdout + return $ const $ return () + reportResult :: [RunResult] -> IO () -reportResult [] = - print (0::Int) reportResult results = do let runtimes = map (fromIntegral . runMicroseconds) results avg = sum runtimes / fromIntegral (length runtimes) rsd = stddevp runtimes / mean runtimes :: Double putStrLn $ printf "%10.0fμs (RSD: %.3f; min: %3.0f%%; max: %+3.0f%%)" - avg rsd ((minimum runtimes / avg - 1) * 100) ((maximum runtimes / avg - 1) * 100) - -runOptions :: BenchOptions -> RunOptions -runOptions opts = RunOptions { runRunner = optRunner opts - , runRuns = optRuns opts - , runExtraOptions = optExtraOptions opts - , runTimeout = optTimeout opts - , runVerbose = optVerbose opts - } + avg rsd ((minimum runtimes / avg - 1) * 100) ((maxinum runtimes / avg - 1) * 100) runBenchmarkCase :: BenchOptions -> FilePath -> T.Text -> Int -> TestRun -> IO (Maybe DataResult) @@ -176,19 +212,29 @@ | any (`elem` tags) $ optExcludeCase opts = return Nothing runBenchmarkCase opts 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 -- error occurs it's easier to see where. - putStr $ dataset_desc ++ ": " ++ - replicate (pad_to - length dataset_desc) ' ' - hFlush stdout + prompt Nothing - res <- benchmarkDataset (runOptions opts) program entry input_spec expected_spec + res <- benchmarkDataset (runOptions (prompt . Just) opts) + program entry input_spec expected_spec (testRunReferenceOutput program entry tr) + + when fancyTerminal $ do + clearLine + putStr "\r" + case res of Left err -> do + liftIO $ putStrLn $ descString dataset_desc pad_to liftIO $ putStrLn $ inRed $ T.unpack err return $ Just $ DataResult dataset_desc $ Left err Right (runtimes, errout) -> do + when fancyTerminal $ + putStr $ descString dataset_desc pad_to + reportResult runtimes return $ Just $ DataResult dataset_desc $ Right (runtimes, errout) diff --git a/src/Futhark/CLI/C.hs b/src/Futhark/CLI/C.hs --- a/src/Futhark/CLI/C.hs +++ b/src/Futhark/CLI/C.hs @@ -16,8 +16,8 @@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile sequential C" "Generate sequential C code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do - cprog <- SequentialC.compileProg prog + sequentialCpuPipeline $ \fcfg () mode outpath prog -> do + cprog <- handleWarnings fcfg $ SequentialC.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h" diff --git a/src/Futhark/CLI/CSOpenCL.hs b/src/Futhark/CLI/CSOpenCL.hs deleted file mode 100644 --- a/src/Futhark/CLI/CSOpenCL.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | @futhark csopencl@ -module Futhark.CLI.CSOpenCL (main) where - -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe) -import System.Directory -import System.Environment -import System.Exit -import System.FilePath - -import Futhark.Passes -import Futhark.Pipeline -import qualified Futhark.CodeGen.Backends.CSOpenCL as CSOpenCL -import Futhark.Compiler.CLI -import Futhark.Util - --- | Run @futhark csopencl@. -main :: String -> [String] -> IO () -main = compilerMain () [] - "Compile OpenCL C#" "Generate OpenCL C# code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" - - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - csprog <- CSOpenCL.compileProg class_name prog - - let cspath = outpath `addExtension` "cs" - liftIO $ writeFile cspath csprog - - case mode of - ToLibrary -> return () - ToExecutable -> do - ret <- liftIO $ runProgramWithExitCode "csc" - ["-out:" ++ outpath, "-lib:"++mono_libs, "-r:Cloo.clSharp.dll,Mono.Options.dll", cspath, "/unsafe"] mempty - case ret of - Left err -> - externalErrorS $ "Failed to run csc: " ++ show err - Right (ExitFailure code, cscwarn, cscerr) -> - externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn - Right (ExitSuccess, _, _) -> liftIO $ do - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/CSharp.hs b/src/Futhark/CLI/CSharp.hs deleted file mode 100644 --- a/src/Futhark/CLI/CSharp.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | @futhark csharp@ -module Futhark.CLI.CSharp (main) where - -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe) -import System.FilePath -import System.Directory -import System.Exit -import System.Environment - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.SequentialCSharp as SequentialCS -import Futhark.Compiler.CLI -import Futhark.Util - --- | Run @futhark csharp@ -main :: String -> [String] -> IO () -main = compilerMain () [] - "Compile sequential C#" "Generate sequential C# code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do - mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - csprog <- SequentialCS.compileProg class_name prog - - let cspath = outpath `addExtension` "cs" - liftIO $ writeFile cspath csprog - - case mode of - ToLibrary -> return () - ToExecutable -> do - ret <- liftIO $ runProgramWithExitCode "csc" - ["-out:" ++ outpath - , "-lib:"++mono_libs - , "-r:Cloo.clSharp.dll" - , "-r:Mono.Options.dll" - , cspath - , "/unsafe"] mempty - case ret of - Left err -> - externalErrorS $ "Failed to run csc: " ++ show err - Right (ExitFailure code, cscwarn, cscerr) -> - externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn - Right (ExitSuccess, _, _) -> liftIO $ do - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/CUDA.hs b/src/Futhark/CLI/CUDA.hs --- a/src/Futhark/CLI/CUDA.hs +++ b/src/Futhark/CLI/CUDA.hs @@ -6,7 +6,6 @@ import System.FilePath import System.Exit -import Futhark.Pipeline import Futhark.Passes import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA import Futhark.Util @@ -16,11 +15,12 @@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile CUDA" "Generate CUDA/C code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - cprog <- CCUDA.compileProg prog + gpuPipeline $ \fcfg () mode outpath prog -> do + cprog <- handleWarnings fcfg $ CCUDA.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h" extra_options = [ "-lcuda" + , "-lcudart" , "-lnvrtc" ] case mode of 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 @@ -325,10 +325,6 @@ (NoArg $ Right $ \opts -> opts { futharkAction = KernelsMemAction kernelImpCodeGenAction }) "Translate program into the imperative IL with kernels and write it on standard output." - , Option [] ["range-analysis"] - (NoArg $ Right $ \opts -> - opts { futharkAction = PolyAction $ AllActions rangeAction rangeAction rangeAction rangeAction rangeAction }) - "Print the program with range annotations added." , Option "p" ["print"] (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction $ AllActions printAction printAction printAction printAction printAction }) diff --git a/src/Futhark/CLI/OpenCL.hs b/src/Futhark/CLI/OpenCL.hs --- a/src/Futhark/CLI/OpenCL.hs +++ b/src/Futhark/CLI/OpenCL.hs @@ -17,8 +17,8 @@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile OpenCL" "Generate OpenCL/C code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - cprog <- COpenCL.compileProg prog + gpuPipeline $ \fcfg () mode outpath prog -> do + cprog <- handleWarnings fcfg $ COpenCL.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h" extra_options 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 @@ -29,7 +29,7 @@ import Futhark.Pkg.Types import Futhark.Pkg.Info import Futhark.Pkg.Solve -import Futhark.Util (directoryContents) +import Futhark.Util (directoryContents, maxinum) import Futhark.Util.Log --- Installing packages @@ -386,7 +386,7 @@ m (unwords [prog, cmd]) args' _ -> do let bad _ () = Just $ do - let k = maximum (map (length . fst) commands) + 3 + let k = maxinum (map (length . fst) commands) + 3 usageMsg $ T.unlines $ [" ...:", "", "Commands:"] ++ [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc 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 @@ -14,11 +14,11 @@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile PyOpenCL" "Generate Python + OpenCL code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do + gpuPipeline $ \fcfg () mode outpath prog -> do let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing - pyprog <- PyOpenCL.compileProg class_name prog + pyprog <- handleWarnings fcfg $ PyOpenCL.compileProg class_name prog case mode of ToLibrary -> 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 @@ -14,11 +14,11 @@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile sequential Python" "Generate sequential Python code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do + sequentialCpuPipeline $ \fcfg () mode outpath prog -> do let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing - pyprog <- SequentialPy.compileProg class_name prog + pyprog <- handleWarnings fcfg $ SequentialPy.compileProg class_name prog case mode of ToLibrary -> 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 @@ -23,7 +23,6 @@ import System.Directory import System.FilePath import System.Console.GetOpt -import System.IO import Text.Read (readMaybe) import qualified System.Console.Haskeline as Haskeline @@ -50,14 +49,15 @@ -- | Run @futhark repl@. main :: String -> [String] -> IO () -main = mainWithOptions interpreterConfig options "options..." run - where run [] _ = Just repl +main = mainWithOptions interpreterConfig options "options... [program.fut]" run + where run [] _ = Just $ repl Nothing + run [prog] _ = Just $ repl $ Just prog run _ _ = Nothing data StopReason = EOF | Stop | Exit | Load FilePath -repl :: IO () -repl = do +repl :: Maybe FilePath -> IO () +repl maybe_prog = do putStr banner putStrLn $ "Version " ++ showVersion version ++ "." putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license." @@ -85,7 +85,7 @@ quit <- confirmQuit if quit then return () else toploop s - maybe_init_state <- liftIO $ newFutharkiState 0 Nothing + maybe_init_state <- liftIO $ newFutharkiState 0 maybe_prog case maybe_init_state of Left err -> error $ "Failed to initialise interpreter state: " ++ err Right init_state -> Haskeline.runInputT Haskeline.defaultSettings $ toploop init_state @@ -131,6 +131,7 @@ -- ^ Are we currently stopped at a breakpoint? , futharkiSkipBreaks :: [Loc] -- ^ Skip breakpoints at these locations. + , futharkiBreakOnNaN :: Bool , futharkiLoaded :: Maybe FilePath -- ^ The currently loaded file. } @@ -159,7 +160,7 @@ liftIO (runExceptT (readProgram file) `catch` \(err::IOException) -> return (externalErrorS (show err))) - liftIO $ hPrint stderr ws + liftIO $ print ws let imp = T.mkInitialImport "." ienv1 <- foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ @@ -178,6 +179,7 @@ , futharkiEnv = (tenv, ienv) , futharkiBreaking = Nothing , futharkiSkipBreaks = mempty + , futharkiBreakOnNaN = False , futharkiLoaded = maybe_file } where badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a @@ -293,6 +295,16 @@ prettyBreaking b = prettyStacktrace (breakingAt b) $ map locStr $ NE.toList $ breakingStack b +-- Are we currently willing to break for this reason? Among othe +-- things, we do not want recursive breakpoints. It could work fine +-- technically, but is probably too confusing to be useful. +breakForReason :: FutharkiState -> I.StackFrame -> I.BreakReason -> Bool +breakForReason s _ I.BreakNaN + | not $ futharkiBreakOnNaN s = False +breakForReason s top _ = + isNothing (futharkiBreaking s) && + locOf top `notElem` futharkiSkipBreaks s + runInterpreter :: F I.ExtOp a -> FutharkiM (Either I.InterpreterError a) runInterpreter m = runF m (return . Right) intOp where @@ -301,19 +313,19 @@ intOp (I.ExtOpTrace w v c) = do liftIO $ putStrLn $ "Trace at " ++ locStr (srclocOf w) ++ ": " ++ v c - intOp (I.ExtOpBreak callstack c) = do + intOp (I.ExtOpBreak why callstack c) = do s <- get - let top = NE.head callstack + let why' = case why of I.BreakPoint -> "Breakpoint" + I.BreakNaN -> "NaN produced" + top = NE.head callstack ctx = I.stackFrameCtx top tenv = I.typeCheckerEnv $ I.ctxEnv ctx breaking = Breaking callstack 0 - -- Are we supposed to skip this breakpoint? Also, We do not - -- want recursive breakpoints. It could work fine technically, - -- but is probably too confusing to be useful. - unless (isJust (futharkiBreaking s) || locOf top `elem` futharkiSkipBreaks s) $ do - liftIO $ putStrLn $ "Breakpoint at " ++ locStr top + -- Are we supposed to respect this breakpoint? + when (breakForReason s top why) $ do + liftIO $ putStrLn $ why' <> " at " ++ locStr top liftIO $ putStrLn $ prettyBreaking breaking liftIO $ putStrLn " to continue." @@ -330,8 +342,13 @@ case stop of Left (Load file) -> throwError $ Load file _ -> do liftIO $ putStrLn "Continuing..." - put s { futharkiCount = futharkiCount s' - , futharkiSkipBreaks = futharkiSkipBreaks s' <> futharkiSkipBreaks s } + put s { futharkiCount = + futharkiCount s' + , futharkiSkipBreaks = + futharkiSkipBreaks s' <> futharkiSkipBreaks s + , futharkiBreakOnNaN = + futharkiBreakOnNaN s' + } c @@ -341,7 +358,7 @@ intOp (I.ExtOpTrace w v c) = do liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v c - intOp (I.ExtOpBreak _ c) = c + intOp (I.ExtOpBreak _ _ c) = c type Command = T.Text -> FutharkiM () @@ -386,6 +403,15 @@ Just top' -> do modify $ \s -> s { futharkiSkipBreaks = locOf top' : futharkiSkipBreaks s } throwError Stop +nanbreakCommand :: Command +nanbreakCommand _ = do + modify $ \s -> s { futharkiBreakOnNaN = not $ futharkiBreakOnNaN s } + b <- gets futharkiBreakOnNaN + liftIO $ putStrLn $ + if b + then "Now treating NaNs as breakpoints." + else "No longer treating NaNs as breakpoints." + frameCommand :: Command frameCommand which = do maybe_stack <- gets $ fmap breakingStack . futharkiBreaking @@ -447,6 +473,10 @@ |])), ("unbreak", (unbreakCommand, [text| Skip all future occurences of the current breakpoint. +|])), + ("nanbreak", (nanbreakCommand, [text| +Toggle treating operators that produce new NaNs as breakpoints. We consider a NaN +to be "new" if none of the arguments to the operator in question is a NaN. |])), ("frame", (frameCommand, [text| While at a break point, jump to another stack frame, whose variables can then 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 @@ -32,7 +32,7 @@ -- | Run @futhark run@. main :: String -> [String] -> IO () -main = mainWithOptions interpreterConfig options "options... program" run +main = mainWithOptions interpreterConfig options "options... " run where run [prog] config = Just $ interpret config prog run _ _ = Nothing @@ -108,7 +108,7 @@ `catch` \(err::IOException) -> return (externalErrorS (show err))) when (interpreterPrintWarnings cfg) $ - liftIO $ hPrint stderr ws + liftIO $ hPutStr stderr $ show ws let imp = T.mkInitialImport "." ienv1 <- foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ @@ -133,4 +133,4 @@ intOp (I.ExtOpTrace w v c) = do liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v c - intOp (I.ExtOpBreak _ c) = c + intOp (I.ExtOpBreak _ _ c) = c 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 @@ -27,6 +27,7 @@ import Futhark.Analysis.Metrics import Futhark.Test +import Futhark.Util (fancyTerminal) import Futhark.Util.Options import Futhark.Util.Pretty (prettyText) import Futhark.Util.Console @@ -150,12 +151,12 @@ ExitFailure 1 -> throwError $ T.decodeUtf8 err ExitFailure _ -> checkError expected_error err - RunCases _ _ warnings | mode == TypeCheck -> do + 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 "" - testWarnings warnings err + case code of ExitSuccess -> return () ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark @@ -401,12 +402,13 @@ let (excluded, included) = partition (excludedTest config) all_tests _ <- forkIO $ mapM_ (putMVar testmvar . excludeCases config) included - isTTY <- (&& not (configLineOutput config)) <$> hIsTerminalDevice stdout - let report | isTTY = reportTable + let fancy = not (configLineOutput config) && fancyTerminal + + report | fancy = reportTable | otherwise = reportText - clear | isTTY = clearFromCursorToScreenEnd - |otherwise = putStr "\n" + clear | fancy = clearFromCursorToScreenEnd + | otherwise = putStr "\n" numTestCases tc = case testAction $ testCaseTest tc of @@ -421,7 +423,7 @@ msg <- takeMVar reportmvar case msg of TestStarted test -> do - unless isTTY $ + unless fancy $ putStr $ "Started testing " <> testCaseProgram test <> " " getResults $ ts {testStatusRun = test : testStatusRun ts} TestDone test res -> do @@ -435,14 +437,14 @@ let ts'' = ts' { testStatusRunPass = testStatusRunPass ts' + numTestCases test } - unless isTTY $ + unless fancy $ putStr $ "Finished testing " <> testCaseProgram test <> " " getResults $ ts'' { testStatusPass = testStatusPass ts + 1} Failure s -> do - when isTTY moveCursorToTableTop + when fancy moveCursorToTableTop clear T.putStr $ (T.pack (inRed $ testCaseProgram test) <> ":\n") <> T.unlines s - when isTTY spaceTable + when fancy spaceTable getResults $ ts' { testStatusFail = testStatusFail ts' + 1 , testStatusRunPass = testStatusRunPass ts' + numTestCases test - length s @@ -451,7 +453,7 @@ + length s } - when isTTY spaceTable + when fancy spaceTable ts <- getResults TestStatus { testStatusRemain = included , testStatusRun = [] @@ -465,7 +467,7 @@ } -- Removes "Now testing" output. - when isTTY $ cursorUpLine 1 >> clearLine + when fancy $ cursorUpLine 1 >> clearLine let excluded_str | null excluded = "" | otherwise = " (" ++ show (length excluded) ++ " program(s) excluded).\n" 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 @@ -24,13 +24,17 @@ import Futhark.CodeGen.Backends.GenericC.Options -- | Compile the program to C with calls to CUDA. -compileProg :: MonadFreshNames m => Prog KernelsMem -> m GC.CParts +compileProg :: MonadFreshNames m => Prog KernelsMem -> m (ImpGen.Warnings, GC.CParts) compileProg prog = do - (Program cuda_code cuda_prelude kernel_names _ sizes failures prog') <- + (ws, Program cuda_code cuda_prelude kernels _ sizes failures prog') <- ImpGen.compileProg prog - let extra = generateBoilerplate cuda_code cuda_prelude - kernel_names sizes failures - GC.compileProg operations extra cuda_includes + let cost_centres = + [copyDevToDev, copyDevToHost, copyHostToDev, + copyScalarToDev, copyScalarFromDev] + extra = generateBoilerplate cuda_code cuda_prelude + cost_centres kernels sizes failures + (ws,) <$> + GC.compileProg "cuda" operations extra cuda_includes [Space "device", DefaultSpace] cliOptions prog' where operations :: GC.Operations OpenCL () @@ -46,6 +50,7 @@ , GC.opsFatMemory = True } cuda_includes = unlines [ "#include " + , "#include " , "#include " ] @@ -79,16 +84,24 @@ , optionArgument = RequiredArgument "OPT" , optionAction = [C.cstm|futhark_context_config_add_nvrtc_option(cfg, optarg);|] } + , Option { optionLongName = "profile" + , optionShortName = Just 'P' + , optionArgument = NoArgument + , optionAction = [C.cstm|futhark_context_config_set_profiling(cfg, 1);|] + } ] writeCUDAScalar :: GC.WriteScalar OpenCL () writeCUDAScalar mem idx t "device" _ val = do val' <- newVName "write_tmp" - GC.stm [C.cstm|{$ty:t $id:val' = $exp:val; + let (bef, aft) = profilingEnclosure copyScalarToDev + GC.item [C.citem|{$ty:t $id:val' = $exp:val; + $items:bef CUDA_SUCCEED( cuMemcpyHtoD($exp:mem + $exp:idx * sizeof($ty:t), &$id:val', sizeof($ty:t))); + $items:aft }|] writeCUDAScalar _ _ _ space _ _ = error $ "Cannot write to '" ++ space ++ "' memory space." @@ -96,12 +109,19 @@ readCUDAScalar :: GC.ReadScalar OpenCL () readCUDAScalar mem idx t "device" _ = do val <- newVName "read_res" - GC.decl [C.cdecl|$ty:t $id:val;|] - GC.stm [C.cstm|CUDA_SUCCEED( - cuMemcpyDtoH(&$id:val, - $exp:mem + $exp:idx * sizeof($ty:t), - sizeof($ty:t))); - |] + let (bef, aft) = profilingEnclosure copyScalarFromDev + mapM_ GC.item + [C.citems| + $ty:t $id:val; + { + $items:bef + CUDA_SUCCEED( + cuMemcpyDtoH(&$id:val, + $exp:mem + $exp:idx * sizeof($ty:t), + sizeof($ty:t))); + $items:aft + } + |] GC.stm [C.cstm|if (futhark_context_sync(ctx) != 0) { return 1; }|] return [C.cexp|$id:val|] readCUDAScalar _ _ _ space _ = @@ -121,18 +141,23 @@ copyCUDAMemory :: GC.Copy OpenCL () copyCUDAMemory dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do - fn <- memcpyFun dstSpace srcSpace - GC.stm [C.cstm|CUDA_SUCCEED( + let (fn, prof) = memcpyFun dstSpace srcSpace + (bef, aft) = profilingEnclosure prof + GC.item [C.citem|{ + $items:bef + CUDA_SUCCEED( $id:fn($exp:dstmem + $exp:dstidx, $exp:srcmem + $exp:srcidx, $exp:nbytes)); + $items:aft + } |] where - memcpyFun DefaultSpace (Space "device") = return "cuMemcpyDtoH" - memcpyFun (Space "device") DefaultSpace = return "cuMemcpyHtoD" - memcpyFun (Space "device") (Space "device") = return "cuMemcpy" - memcpyFun _ _ = error $ "Cannot copy to '" ++ show dstSpace - ++ "' from '" ++ show srcSpace ++ "'." + memcpyFun DefaultSpace (Space "device") = ("cuMemcpyDtoH", copyDevToHost) + memcpyFun (Space "device") DefaultSpace = ("cuMemcpyHtoD", copyHostToDev) + memcpyFun (Space "device") (Space "device") = ("cuMemcpy", copyDevToDev) + memcpyFun _ _ = error $ "Cannot copy to '" ++ show dstSpace ++ + "' from '" ++ show srcSpace ++ "'." staticCUDAArray :: GC.StaticArray OpenCL () staticCUDAArray name "device" t vs = do @@ -147,7 +172,7 @@ GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] return n -- Fake a memory block. - GC.contextField (pretty name) [C.cty|struct memblock_device|] Nothing + GC.contextField (C.toIdent name mempty) [C.cty|struct memblock_device|] Nothing -- During startup, copy the data to where we need it. GC.atInit [C.cstm|{ ctx->$id:name.references = NULL; @@ -185,7 +210,7 @@ cudaSizeClass SizeTile = "tile_size" cudaSizeClass SizeLocalMemory = "shared_memory" cudaSizeClass (SizeBespoke x _) = pretty x -callKernel (LaunchKernel safety name args num_blocks block_size) = do +callKernel (LaunchKernel safety kernel_name args num_blocks block_size) = do args_arr <- newVName "kernel_args" time_start <- newVName "time_start" time_end <- newVName "time_end" @@ -194,9 +219,8 @@ shared_offsets_sc = mkOffsets shared_sizes shared_args = zip shared_offsets shared_offsets_sc shared_tot = last shared_offsets_sc - mapM_ (\(arg,offset) -> - GC.decl [C.cdecl|unsigned int $id:arg = $exp:offset;|] - ) shared_args + forM_ shared_args $ \(arg,offset) -> + GC.decl [C.cdecl|unsigned int $id:arg = $exp:offset;|] (grid_x, grid_y, grid_z) <- mkDims <$> mapM GC.compileExp num_blocks (block_x, block_y, block_z) <- mkDims <$> mapM GC.compileExp block_size @@ -210,17 +234,18 @@ args'' = perm_args ++ failure_args ++ [ [C.cinit|&$id:a|] | a <- args' ] sizes_nonzero = expsNotZero [grid_x, grid_y, grid_z, block_x, block_y, block_z] + (bef, aft) = profilingEnclosure kernel_name GC.stm [C.cstm| if ($exp:sizes_nonzero) { int perm[3] = { 0, 1, 2 }; - if ($exp:grid_y > (1<<16)) { + if ($exp:grid_y >= (1<<16)) { perm[1] = perm[0]; perm[0] = 1; } - if ($exp:grid_z > (1<<16)) { + if ($exp:grid_z >= (1<<16)) { perm[2] = perm[0]; perm[0] = 2; } @@ -233,24 +258,26 @@ 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:name); + fprintf(stderr, "Launching %s with grid size (", $string:(pretty kernel_name)); $stms:(printSizes [grid_x, grid_y, grid_z]) fprintf(stderr, ") and block size ("); $stms:(printSizes [block_x, block_y, block_z]) fprintf(stderr, ").\n"); $id:time_start = get_wall_time(); } + $items:bef CUDA_SUCCEED( - cuLaunchKernel(ctx->$id:name, + cuLaunchKernel(ctx->$id:kernel_name, grid[0], grid[1], grid[2], $exp:block_x, $exp:block_y, $exp:block_z, $exp:shared_tot, NULL, $id:args_arr, NULL)); + $items:aft if (ctx->debugging) { CUDA_SUCCEED(cuCtxSynchronize()); $id:time_end = get_wall_time(); fprintf(stderr, "Kernel %s runtime: %ldus\n", - $string:name, $id:time_end - $id:time_start); + $string:(pretty kernel_name), $id:time_end - $id:time_start); } }|] 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 @@ -4,13 +4,19 @@ module Futhark.CodeGen.Backends.CCUDA.Boilerplate ( generateBoilerplate + , profilingEnclosure + , module Futhark.CodeGen.Backends.COpenCL.Boilerplate ) where +import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.ImpCode.OpenCL -import Futhark.CodeGen.Backends.COpenCL.Boilerplate (failureSwitch) +import Futhark.CodeGen.Backends.COpenCL.Boilerplate + (failureSwitch, kernelRuntime, kernelRuns, costCentreReport, + copyDevToDev, copyDevToHost, copyHostToDev, + copyScalarToDev, copyScalarFromDev) import Futhark.Util (chunk, zEncodeString) import qualified Data.Map as M @@ -19,13 +25,31 @@ errorMsgNumArgs :: ErrorMsg a -> Int errorMsgNumArgs = length . errorMsgArgTypes +-- | Block items to put before and after a thing to be profiled. +profilingEnclosure :: Name -> ([C.BlockItem], [C.BlockItem]) +profilingEnclosure name = + ([C.citems| + typename cudaEvent_t *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(&ctx->cuda, + &ctx->$id:(kernelRuns name), + &ctx->$id:(kernelRuntime name)); + CUDA_SUCCEED(cudaEventRecord(pevents[0], 0)); + } + |], + [C.citems| + if (pevents != NULL) { + CUDA_SUCCEED(cudaEventRecord(pevents[1], 0)); + } + |]) + -- | Called after most code has been generated to generate the bulk of -- the boilerplate. -generateBoilerplate :: String -> String -> M.Map KernelName Safety +generateBoilerplate :: String -> String -> [Name] -> M.Map KernelName KernelSafety -> M.Map Name SizeClass -> [FailureMsg] -> GC.CompilerM OpenCL () () -generateBoilerplate cuda_program cuda_prelude kernels sizes failures = do +generateBoilerplate cuda_program cuda_prelude cost_centres kernels sizes failures = do mapM_ GC.earlyDecl [C.cunit| $esc:("#include ") $esc:("#include ") @@ -37,7 +61,11 @@ generateSizeFuns sizes cfg <- generateConfigFuns sizes - generateContextFuns cfg kernels sizes failures + generateContextFuns cfg cost_centres kernels sizes failures + + GC.profileReport [C.citem|CUDA_SUCCEED(cuda_tally_profiling_records(&ctx->cuda));|] + mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels + where cuda_h = $(embedStringFile "rts/c/cuda.h") free_list_h = $(embedStringFile "rts/c/free_list.h") @@ -81,6 +109,7 @@ cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ([C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s { struct cuda_config cu_cfg; + int profiling; size_t sizes[$int:num_sizes]; int num_nvrtc_opts; const char **nvrtc_opts; @@ -98,6 +127,7 @@ return NULL; } + cfg->profiling = 0; cfg->num_nvrtc_opts = 0; cfg->nvrtc_opts = (const char**) malloc(sizeof(const char*)); cfg->nvrtc_opts[0] = NULL; @@ -130,6 +160,12 @@ cfg->cu_cfg.logging = cfg->cu_cfg.debugging = flag; }|]) + GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { + cfg->profiling = flag; + }|]) + GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { @@ -227,16 +263,32 @@ }|]) return cfg -generateContextFuns :: String -> M.Map KernelName Safety +generateContextFuns :: String -> [Name] -> M.Map KernelName KernelSafety -> M.Map Name SizeClass -> [FailureMsg] -> GC.CompilerM OpenCL () () -generateContextFuns cfg kernels sizes failures = do +generateContextFuns cfg cost_centres kernels sizes failures = do final_inits <- GC.contextFinalInits (fields, init_fields) <- GC.contextContents - let kernel_fields = map (\k -> [C.csdecl|typename CUfunction $id:k;|]) $ - M.keys kernels + let forCostCentre name = + [([C.csdecl|typename int64_t $id:(kernelRuntime name);|], + [C.cstm|ctx->$id:(kernelRuntime name) = 0;|]), + ([C.csdecl|int $id:(kernelRuns name);|], + [C.cstm|ctx->$id:(kernelRuns name) = 0;|])] + forKernel name = + ([C.csdecl|typename CUfunction $id:name;|], + [C.cstm|CUDA_SUCCEED(cuModuleGetFunction( + &ctx->$id:name, + ctx->cuda.module, + $string:(pretty (C.toIdent name mempty))));|]) + : forCostCentre name + + (kernel_fields, init_kernel_fields) = + unzip $ + concatMap forKernel (M.keys kernels) ++ + concatMap forCostCentre cost_centres + ctx <- GC.publicDef "context" GC.InitDecl $ \s -> ([C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s { @@ -254,6 +306,9 @@ struct sizes sizes; // True if a potentially failing kernel has been enqueued. typename int32_t failure_is_an_option; + + int total_runs; + long int total_runtime; };|]) let set_sizes = zipWith (\i k -> [C.cstm|ctx->sizes.$id:k = cfg->sizes[$int:i];|]) @@ -268,13 +323,22 @@ if (ctx == NULL) { return NULL; } - ctx->profiling = ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; + ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; + ctx->profiling = cfg->profiling; + ctx->profiling_paused = 0; ctx->error = NULL; + ctx->cuda.profiling_records_capacity = 200; + ctx->cuda.profiling_records_used = 0; + ctx->cuda.profiling_records = + malloc(ctx->cuda.profiling_records_capacity * + sizeof(struct profiling_record)); ctx->cuda.cfg = cfg->cu_cfg; create_lock(&ctx->lock); ctx->failure_is_an_option = 0; + ctx->total_runs = 0; + ctx->total_runtime = 0; $stms:init_fields cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts); @@ -285,7 +349,7 @@ // The +1 is to avoid zero-byte allocations. CUDA_SUCCEED(cuMemAlloc(&ctx->global_failure_args, sizeof(int32_t)*($int:max_failure_args+1))); - $stms:(map loadKernel (M.toList kernels)) + $stms:init_kernel_fields $stms:final_inits $stms:set_sizes @@ -343,8 +407,3 @@ CUDA_SUCCEED(cuda_free_all(&ctx->cuda)); return 0; }|]) - - where - loadKernel (name, _) = - [C.cstm|CUDA_SUCCEED(cuModuleGetFunction(&ctx->$id:name, - ctx->cuda.module, $string:name));|] diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE QuasiQuotes, FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} -- | Code generation for C with OpenCL. module Futhark.CodeGen.Backends.COpenCL ( compileProg @@ -9,7 +11,6 @@ import Control.Monad hiding (mapM) import Data.List (intercalate) -import qualified Data.Map as M import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C @@ -24,15 +25,15 @@ import Futhark.MonadFreshNames -- | Compile the program to C with calls to OpenCL. -compileProg :: MonadFreshNames m => Prog KernelsMem -> m GC.CParts +compileProg :: MonadFreshNames m => Prog KernelsMem -> m (ImpGen.Warnings, GC.CParts) compileProg prog = do - (Program opencl_code opencl_prelude kernels - types sizes failures prog') <- ImpGen.compileProg prog + (ws, Program opencl_code opencl_prelude kernels + types sizes failures prog') <- ImpGen.compileProg prog let cost_centres = [copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev] - ++ M.keys kernels - GC.compileProg operations + (ws,) <$> + GC.compileProg "opencl" operations (generateBoilerplate opencl_code opencl_prelude cost_centres kernels types sizes failures) include_opencl_h [Space "device", DefaultSpace] @@ -98,7 +99,6 @@ , optionArgument = RequiredArgument "OPT" , optionAction = [C.cstm|futhark_context_config_add_build_option(cfg, optarg);|] } - , Option { optionLongName = "profile" , optionShortName = Just 'P' , optionArgument = NoArgument @@ -228,7 +228,7 @@ GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] return n -- Fake a memory block. - GC.contextField (pretty name) [C.cty|struct memblock_device|] Nothing + GC.contextField (C.toIdent name mempty) [C.cty|struct memblock_device|] Nothing -- During startup, copy the data to where we need it. GC.atInit [C.cstm|{ typename cl_int success; @@ -310,7 +310,7 @@ localBytes cur _ = return cur launchKernel :: C.ToExp a => - String -> [a] -> [a] -> a -> GC.CompilerM op s () + KernelName -> [a] -> [a] -> a -> GC.CompilerM op s () launchKernel kernel_name num_workgroups workgroup_dims local_bytes = do global_work_size <- newVName "global_work_size" time_start <- newVName "time_start" @@ -324,7 +324,7 @@ 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:kernel_name); + fprintf(stderr, "Launching %s with global work size [", $string:(pretty kernel_name)); $stms:(printKernelSize global_work_size) fprintf(stderr, "] and local work size ["); $stms:(printKernelSize local_work_size) @@ -340,7 +340,7 @@ $id:time_end = get_wall_time(); long int $id:time_diff = $id:time_end - $id:time_start; fprintf(stderr, "kernel %s runtime: %ldus\n", - $string:kernel_name, $id:time_diff); + $string:(pretty kernel_name), $id:time_diff); } }|] where kernel_rank = length kernel_dims 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 @@ -1,17 +1,20 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Futhark.CodeGen.Backends.COpenCL.Boilerplate ( generateBoilerplate , profilingEvent , copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev - , kernelRuntime - , kernelRuns - , commonOptions , failureSwitch + , costCentreReport + , kernelRuntime + , kernelRuns ) where +import Control.Monad.State import Data.FileEmbed import qualified Data.Map as M import qualified Language.C.Syntax as C @@ -41,15 +44,14 @@ zipWith onFailure [(0::Int)..] failures in [C.cstm|switch (failure_idx) { $stms:failure_cases }|] - -copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: String +copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: Name copyDevToDev = "copy_dev_to_dev" copyDevToHost = "copy_dev_to_host" copyHostToDev = "copy_host_to_dev" copyScalarToDev = "copy_scalar_to_dev" copyScalarFromDev = "copy_scalar_from_dev" -profilingEvent :: String -> C.Exp +profilingEvent :: Name -> C.Exp profilingEvent name = [C.cexp|(ctx->profiling_paused || !ctx->profiling) ? NULL : opencl_get_event(&ctx->opencl, @@ -58,15 +60,17 @@ -- | Called after most code has been generated to generate the bulk of -- the boilerplate. -generateBoilerplate :: String -> String -> [String] -> M.Map KernelName Safety -> [PrimType] +generateBoilerplate :: String -> String -> [Name] + -> M.Map KernelName KernelSafety + -> [PrimType] -> M.Map Name SizeClass -> [FailureMsg] -> GC.CompilerM OpenCL () () -generateBoilerplate opencl_code opencl_prelude profiling_centres kernels types sizes failures = do +generateBoilerplate opencl_code opencl_prelude cost_centres kernels types sizes failures = do final_inits <- GC.contextFinalInits let (ctx_opencl_fields, ctx_opencl_inits, top_decls, later_top_decls) = - openClDecls profiling_centres kernels opencl_code opencl_prelude + openClDecls cost_centres kernels opencl_code opencl_prelude mapM_ GC.earlyDecl top_decls @@ -441,11 +445,12 @@ }|]) GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(&ctx->opencl));|] - mapM_ GC.profileReport $ openClReport profiling_centres + mapM_ GC.profileReport $ costCentreReport $ + cost_centres ++ M.keys kernels -openClDecls :: [String] -> M.Map KernelName Safety -> String -> String +openClDecls :: [Name] -> M.Map KernelName KernelSafety -> String -> String -> ([C.FieldGroup], [C.Stm], [C.Definition], [C.Definition]) -openClDecls profiling_centres kernels opencl_program opencl_prelude = +openClDecls cost_centres kernels opencl_program opencl_prelude = (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load) where opencl_program_fragments = -- Some C compilers limit the size of literal strings, so @@ -462,7 +467,7 @@ [ [ [C.csdecl|typename int64_t $id:(kernelRuntime name);|] , [C.csdecl|int $id:(kernelRuns name);|] ] - | name <- profiling_centres ] + | name <- cost_centres ++ M.keys kernels ] ctx_inits = [ [C.cstm|ctx->total_runs = 0;|], @@ -471,7 +476,7 @@ [ [ [C.cstm|ctx->$id:(kernelRuntime name) = 0;|] , [C.cstm|ctx->$id:(kernelRuns name) = 0;|] ] - | name <- profiling_centres ] + | name <- cost_centres ++ M.keys kernels ] openCL_load = [ [C.cedecl| @@ -489,13 +494,13 @@ $esc:openCL_h static const char *opencl_program[] = {$inits:program_fragments};|] -loadKernel :: (KernelName, Safety) -> C.Stm +loadKernel :: (KernelName, KernelSafety) -> C.Stm loadKernel (name, safety) = [C.cstm|{ - ctx->$id:name = clCreateKernel(prog, $string:name, &error); + ctx->$id:name = clCreateKernel(prog, $string:(pretty (C.toIdent name mempty)), &error); OPENCL_SUCCEED_FATAL(error); $items:set_args if (ctx->debugging) { - fprintf(stderr, "Created kernel %s.\n", $string:name); + fprintf(stderr, "Created kernel %s.\n", $string:(pretty name)); } }|] where set_global_failure = @@ -511,18 +516,18 @@ SafetyCheap -> [set_global_failure] SafetyFull -> [set_global_failure, set_global_failure_args] -releaseKernel :: (KernelName, Safety) -> C.Stm +releaseKernel :: (KernelName, KernelSafety) -> C.Stm releaseKernel (name, _) = [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseKernel(ctx->$id:name));|] -kernelRuntime :: String -> String -kernelRuntime = (++"_total_runtime") +kernelRuntime :: KernelName -> Name +kernelRuntime = (<>"_total_runtime") -kernelRuns :: String -> String -kernelRuns = (++"_runs") +kernelRuns :: KernelName -> Name +kernelRuns = (<>"_runs") -openClReport :: [String] -> [C.BlockItem] -openClReport names = report_kernels ++ [report_total] - where longest_name = foldl max 0 $ map length names +costCentreReport :: [Name] -> [C.BlockItem] +costCentreReport names = report_kernels ++ [report_total] + where longest_name = foldl max 0 $ map (length . pretty) names report_kernels = concatMap reportKernel names format_string name = let padding = replicate (longest_name - length name) ' ' @@ -533,7 +538,7 @@ total_runtime = kernelRuntime name in [[C.citem| str_builder(&builder, - $string:(format_string name), + $string:(format_string (pretty name)), ctx->$id:runs, (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1), (long int) ctx->$id:total_runtime); @@ -552,7 +557,7 @@ if ($exp:which' == 0 && strstr(option->platform_name, $string:platform_name) != NULL && (option->device_type & $exp:(clDeviceType device_type)) == $exp:(clDeviceType device_type)) { - $stm:get_size + $items:get_size }|] where clDeviceType DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|] clDeviceType DeviceCPU = [C.cexp|CL_DEVICE_TYPE_CPU|] @@ -564,17 +569,27 @@ TileSize -> [C.cexp|ctx->cfg.default_tile_size|] Threshold -> [C.cexp|ctx->cfg.default_threshold|] - get_size = case what of - HeuristicConst x -> - [C.cstm|$exp:which' = $int:x;|] - HeuristicDeviceInfo s -> - -- This only works for device info that fits in the variable. - let s' = "CL_DEVICE_" ++ s - in [C.cstm|clGetDeviceInfo(ctx->device, - $id:s', - sizeof($exp:which'), - &$exp:which', - NULL);|] + get_size = + let (e, m) = runState (GC.compilePrimExp onLeaf what) mempty + in concat (M.elems m) ++ [[C.citem|$exp:which' = $exp:e;|]] + + onLeaf (DeviceInfo s) = do + let s' = "CL_DEVICE_" ++ s + v = s ++ "_val" + m <- get + case M.lookup s m of + Nothing -> + -- Cheating with the type here; works for the infos we + -- currently use, but should be made more size-aware in + -- the future. + modify $ M.insert s' + [C.citems|size_t $id:v; + clGetDeviceInfo(ctx->device, $id:s', + sizeof($id:v), &$id:v, + NULL);|] + Just _ -> return () + + return [C.cexp|$id:v|] -- Options that are common to multiple GPU-like backends. commonOptions :: [Option] diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL.hs b/src/Futhark/CodeGen/Backends/CSOpenCL.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/CSOpenCL.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Futhark.CodeGen.Backends.CSOpenCL - ( compileProg - ) where - -import Control.Monad -import Data.List (intersperse) - -import Futhark.IR.KernelsMem (Prog, KernelsMem, int32) -import Futhark.CodeGen.Backends.CSOpenCL.Boilerplate -import qualified Futhark.CodeGen.Backends.GenericCSharp as CS -import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp -import qualified Futhark.CodeGen.ImpGen.OpenCL as ImpGen -import Futhark.CodeGen.Backends.GenericCSharp.AST -import Futhark.CodeGen.Backends.GenericCSharp.Options -import Futhark.CodeGen.Backends.GenericCSharp.Definitions -import Futhark.Util (zEncodeString) -import Futhark.MonadFreshNames - - -compileProg :: MonadFreshNames m => - Maybe String -> Prog KernelsMem -> m String -compileProg module_name prog = do - Imp.Program opencl_code opencl_prelude kernel_names types sizes failures prog' <- - ImpGen.compileProg prog - CS.compileProg - module_name - CS.emptyConstructor - imports - defines - operations - () - (generateBoilerplate opencl_code opencl_prelude kernel_names types sizes failures) - [] - [Imp.Space "device", Imp.Space "local", Imp.DefaultSpace] - cliOptions - prog' - - where operations :: CS.Operations Imp.OpenCL () - operations = CS.defaultOperations - { CS.opsCompiler = callKernel - , CS.opsWriteScalar = writeOpenCLScalar - , CS.opsReadScalar = readOpenCLScalar - , CS.opsAllocate = allocateOpenCLBuffer - , CS.opsCopy = copyOpenCLMemory - , CS.opsStaticArray = staticOpenCLArray - , CS.opsEntryInput = unpackArrayInput - , CS.opsEntryOutput = packArrayOutput - , CS.opsSyncRun = futharkSyncContext - } - imports = [ Using Nothing "System.Runtime.CompilerServices" - , Using Nothing "Cloo" - , Using Nothing "Cloo.Bindings" ] - defines = [ Escape csOpenCL - , Escape csMemoryOpenCL ] -cliOptions :: [Option] -cliOptions = [ Option { optionLongName = "platform" - , optionShortName = Just 'p' - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetPlatform(ref Cfg, optarg);"] - } - , Option { optionLongName = "device" - , optionShortName = Just 'd' - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetDevice(ref Cfg, optarg);"] - } - , Option { optionLongName = "dump-opencl" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigDumpProgramTo(ref Cfg, optarg);"] - } - , Option { optionLongName = "load-opencl" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigLoadProgramFrom(ref Cfg, optarg);"] - } - , Option { optionLongName = "debugging" - , optionShortName = Just 'D' - , optionArgument = NoArgument - , optionAction = [Escape "FutharkContextConfigSetDebugging(ref Cfg, true);"] - } - , Option { optionLongName = "default-group-size" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetDefaultGroupSize(ref Cfg, Convert.ToInt32(optarg));"] - } - , Option { optionLongName = "default-num-groups" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetDefaultNumGroups(ref Cfg, Convert.ToInt32(optarg));"] - } - , Option { optionLongName = "default-tile-size" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetDefaultTileSize(ref Cfg, Convert.ToInt32(optarg));"] - } - , Option { optionLongName = "default-threshold" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkContextConfigSetDefaultThreshold(ref Cfg, Convert.ToInt32(optarg));"] - } - , Option { optionLongName = "print-sizes" - , optionShortName = Nothing - , optionArgument = NoArgument - , optionAction = [Escape "FutharkConfigPrintSizes();"] - } - , Option { optionLongName = "size" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkConfigSetSize(ref Cfg, optarg);"] - } - , Option { optionLongName = "tuning" - , optionShortName = Nothing - , optionArgument = RequiredArgument - , optionAction = [Escape "FutharkConfigLoadTuning(ref Cfg, optarg);"] - } - ] - -callKernel :: CS.OpCompiler Imp.OpenCL () -callKernel (Imp.GetSize v key) = - CS.stm $ Reassign (Var (CS.compileName v)) $ - Field (Var "Ctx.Sizes") $ zEncodeString $ pretty key - -callKernel (Imp.GetSizeMax v size_class) = do - v' <- CS.compileVar v - CS.stm $ Reassign v' $ - Field (Var "Ctx.OpenCL") $ - case size_class of Imp.SizeGroup -> "MaxGroupSize" - Imp.SizeNumGroups -> "MaxNumGroups" - Imp.SizeTile -> "MaxTileSize" - Imp.SizeThreshold{} -> "MaxThreshold" - Imp.SizeLocalMemory -> "MaxLocalMemory" - Imp.SizeBespoke{} -> "MaxBespoke" - -callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do - num_workgroups' <- mapM CS.compileExp num_workgroups - workgroup_size' <- mapM CS.compileExp workgroup_size - let kernel_size = zipWith mult_exp num_workgroups' workgroup_size' - total_elements = foldl mult_exp (Integer 1) kernel_size - cond = BinOp "!=" total_elements (Integer 0) - body <- CS.collect $ launchKernel safety name kernel_size workgroup_size' args - CS.stm $ If cond body [] - where mult_exp = BinOp "*" - -callKernel (Imp.CmpSizeLe v key x) = do - v' <- CS.compileVar v - x' <- CS.compileExp x - CS.stm $ Reassign v' $ - BinOp "<=" (Field (Var "Ctx.Sizes") (zEncodeString $ pretty key)) x' - -launchKernel :: Imp.Safety -> String -> [CSExp] -> [CSExp] -> [Imp.KernelArg] -> CS.CompilerM op s () -launchKernel safety kernel_name kernel_dims workgroup_dims args = do - let kernel_name' = "Ctx."++kernel_name - - let failure_args = - [ processMemArg kernel_name' 0 $ Var "Ctx.GlobalFailure" - , processValueArg kernel_name' 1 int32 $ Var "Ctx.GlobalFailureIsAnOption" - , processMemArg kernel_name' 2 $ Var "Ctx.GlobalFailureArgs"] - - failure_args' <- concat <$> sequence (take (Imp.numFailureParams safety) failure_args) - - args_stms <- zipWithM (processKernelArg kernel_name') - [toInteger (Imp.numFailureParams safety)..] args - CS.stm $ Unsafe $ failure_args' ++ concat args_stms - - global_work_size <- newVName' "GlobalWorkSize" - local_work_size <- newVName' "LocalWorkSize" - stop_watch <- newVName' "StopWatch" - time_diff <- newVName' "TimeDiff" - - let debugStartStmts = - map Exp $ [CS.consoleErrorWrite "Launching {0} with global work size [" [String kernel_name]] ++ - printKernelSize global_work_size ++ - [ CS.consoleErrorWrite "] and local work size [" []] ++ - printKernelSize local_work_size ++ - [ CS.consoleErrorWrite "].\n" [] - , CallMethod (Var stop_watch) (Var "Start") []] - - let ctx = (++) "Ctx." - let debugEndStmts = - [ Exp $ CS.simpleCall "FutharkContextSync" [] - , Exp $ CallMethod (Var stop_watch) (Var "Stop") [] - , Assign (Var time_diff) $ asMicroseconds (Var stop_watch) - , AssignOp "+" (Var $ ctx $ kernelRuntime kernel_name) (Var time_diff) - , AssignOp "+" (Var $ ctx $ kernelRuns kernel_name) (Integer 1) - , Exp $ CS.consoleErrorWriteLine "kernel {0} runtime: {1}" [String kernel_name, Var time_diff] - ] - - - CS.stm $ If (BinOp "!=" total_elements (Integer 0)) - ([ Assign (Var global_work_size) (Collection "IntPtr[]" $ map CS.toIntPtr kernel_dims) - , Assign (Var local_work_size) (Collection "IntPtr[]" $ map CS.toIntPtr workgroup_dims) - , Assign (Var stop_watch) $ CS.simpleInitClass "Stopwatch" [] - , If (Var "Ctx.Debugging") debugStartStmts [] - ] - ++ - [ Exp $ CS.simpleCall "OPENCL_SUCCEED" [ - CS.simpleCall "CL10.EnqueueNDRangeKernel" - [ Var "Ctx.OpenCL.Queue", Var kernel_name', Integer kernel_rank, Null - , Var global_work_size, Var local_work_size, Integer 0, Null, Null]]] - ++ - [ If (Var "Ctx.Debugging") debugEndStmts [] ]) [] - - when (safety >= Imp.SafetyFull) $ - CS.stm $ Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 1) - - finishIfSynchronous - - where processMemArg kernel argnum mem = do - err <- newVName' "setargErr" - dest <- newVName "kArgDest" - let err_var = Var err - dest' <- CS.compileVar dest - return [ Fixed dest' (Addr mem) - [ Assign err_var $ getKernelCall kernel argnum - (CS.sizeOf $ Primitive IntPtrT) dest'] - ] - - processValueArg kernel argnum et e = do - let t = CS.compilePrimTypeToAST et - tmp <- newVName' "kernelArg" - err <- newVName' "setargErr" - let err_var = Var err - return [ AssignTyped t (Var tmp) (Just e) - , Assign err_var $ getKernelCall kernel argnum (CS.sizeOf t) (Addr $ Var tmp)] - - processKernelArg :: String - -> Integer - -> Imp.KernelArg - -> CS.CompilerM op s [CSStmt] - processKernelArg kernel argnum (Imp.ValueKArg e et) = - processValueArg kernel argnum et =<< CS.compileExp e - processKernelArg kernel argnum (Imp.MemKArg v) = - processMemArg kernel argnum . memblockFromMem =<< CS.compileVar v - - processKernelArg kernel argnum (Imp.SharedMemoryKArg (Imp.Count num_bytes)) = do - err <- newVName' "setargErr" - let err_var = Var err - num_bytes' <- CS.compileExp num_bytes - return [ Assign err_var $ getKernelCall kernel argnum num_bytes' Null ] - - kernel_rank = toInteger $ length kernel_dims - total_elements = foldl (BinOp "*") (Integer 1) kernel_dims - - printKernelSize :: String -> [CSExp] - printKernelSize work_size = - intersperse (CS.consoleErrorWrite ", " []) $ map (printKernelDim work_size) [0..kernel_rank-1] - - printKernelDim global_work_size i = - CS.consoleErrorWrite "{0}" [Index (Var global_work_size) (IdxExp (Integer $ toInteger i))] - - asMicroseconds watch = - BinOp "/" (Field watch "ElapsedTicks") - (BinOp "/" (Field (Var "TimeSpan") "TicksPerMillisecond") (Integer 1000)) - - - -getKernelCall :: String -> Integer -> CSExp -> CSExp -> CSExp -getKernelCall kernel arg_num size Null = - CS.simpleCall "CL10.SetKernelArg" [ Var kernel, Integer arg_num, CS.toIntPtr size, Var "Ctx.NULL"] -getKernelCall kernel arg_num size e = - CS.simpleCall "CL10.SetKernelArg" [ Var kernel, Integer arg_num, CS.toIntPtr size, CS.toIntPtr e] - -writeOpenCLScalar :: CS.WriteScalar Imp.OpenCL () -writeOpenCLScalar mem i bt "device" val = do - let bt' = CS.compilePrimTypeToAST bt - scalar <- newVName' "scalar" - ptr <- newVName' "ptr" - CS.stm $ Unsafe - [ AssignTyped bt' (Var scalar) (Just val) - , AssignTyped (PointerT VoidT) (Var ptr) (Just $ Addr $ Var scalar) - , Exp $ CS.simpleCall "CL10.EnqueueWriteBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem mem, Bool True - , CS.toIntPtr $ BinOp "*" i (CS.sizeOf bt') - , CS.toIntPtr $ CS.sizeOf bt',CS.toIntPtr $ Var ptr - , Integer 0, Null, Null] - ] - -writeOpenCLScalar _ _ _ space _ = - error $ "Cannot write to '" ++ space ++ "' memory space." - -readOpenCLScalar :: CS.ReadScalar Imp.OpenCL () -readOpenCLScalar mem i bt "device" = do - val <- newVName' "read_res" - ptr <- newVName' "ptr" - let bt' = CS.compilePrimTypeToAST bt - CS.stm $ AssignTyped bt' (Var val) (Just $ CS.simpleInitClass (pretty bt') []) - CS.stm $ Unsafe - [ CS.assignScalarPointer (Var val) (Var ptr) - , Exp $ CS.simpleCall "CL10.EnqueueReadBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem mem , Bool True - , CS.toIntPtr $ BinOp "*" i (CS.sizeOf bt') - , CS.toIntPtr $ CS.sizeOf bt', CS.toIntPtr $ Var ptr - , Integer 0, Null, Null] - ] - return $ Var val - -readOpenCLScalar _ _ _ space = - error $ "Cannot read from '" ++ space ++ "' memory space." - -computeErrCodeT :: CSType -computeErrCodeT = CustomT "ComputeErrorCode" - -allocateOpenCLBuffer :: CS.Allocate Imp.OpenCL () -allocateOpenCLBuffer mem size "device" = do - errcode <- CS.compileName <$> newVName "errCode" - CS.stm $ AssignTyped computeErrCodeT (Var errcode) Nothing - CS.stm $ Reassign mem (CS.simpleCall "MemblockAllocDevice" [Ref $ Var "Ctx", mem, size, String $ pretty mem]) - -allocateOpenCLBuffer _ _ space = - error $ "Cannot allocate in '" ++ space ++ "' space" - -copyOpenCLMemory :: CS.Copy Imp.OpenCL () -copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx (Imp.Space "device") nbytes _ = do - ptr <- newVName' "ptr" - CS.stm $ Fixed (Var ptr) (Addr $ Index destmem $ IdxExp $ Integer 0) - [ ifNotZeroSize nbytes $ - Exp $ CS.simpleCall "CL10.EnqueueReadBuffer" - [ Var "Ctx.Opencl.Queue", memblockFromMem srcmem, Bool True - , CS.toIntPtr srcidx, nbytes,CS.toIntPtr $ Var ptr - , CS.toIntPtr destidx, Null, Null] - ] - -copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes _ = do - ptr <- newVName' "ptr" - CS.stm $ Fixed (Var ptr) (Addr $ Index srcmem $ IdxExp $ Integer 0) - [ ifNotZeroSize nbytes $ - Exp $ CS.simpleCall "CL10.EnqueueWriteBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem destmem, Bool True - , CS.toIntPtr destidx, CS.toIntPtr nbytes, CS.toIntPtr $ Var ptr - , srcidx, Null, Null] - ] - -copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx (Imp.Space "device") nbytes _ = do - CS.stm $ ifNotZeroSize nbytes $ - Exp $ CS.simpleCall "CL10.EnqueueCopyBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem srcmem, memblockFromMem destmem - , CS.toIntPtr srcidx, CS.toIntPtr destidx, CS.toIntPtr nbytes - , Integer 0, Null, Null] - finishIfSynchronous - -copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx Imp.DefaultSpace nbytes _ = - CS.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes - -copyOpenCLMemory _ _ destspace _ _ srcspace _ _= - error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace - -staticOpenCLArray :: CS.StaticArray Imp.OpenCL () -staticOpenCLArray name "device" t vs = do - name' <- CS.compileVar name - CS.staticMemDecl $ AssignTyped (CustomT "OpenCLMemblock") name' Nothing - - -- Create host-side C# array with intended values. - tmp_arr <- newVName' "tmpArr" - let t' = CS.compilePrimTypeToAST t - CS.staticMemDecl $ AssignTyped (Composite $ ArrayT t') (Var tmp_arr) $ Just $ - case vs of Imp.ArrayValues vs' -> - CreateArray (CS.compilePrimTypeToAST t) $ Right $ map CS.compilePrimValue vs' - Imp.ArrayZeros n -> - CreateArray (CS.compilePrimTypeToAST t) $ Left n - - -- Create memory block on the device. - ptr <- newVName' "ptr" - let num_elems = case vs of Imp.ArrayValues vs' -> length vs' - Imp.ArrayZeros n -> n - size = Integer $ toInteger num_elems * Imp.primByteSize t - - CS.staticMemAlloc $ Reassign name' $ - CS.simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"] - errcode <- CS.compileName <$> newVName "errCode" - CS.staticMemAlloc $ AssignTyped computeErrCodeT (Var errcode) Nothing - CS.staticMemAlloc $ Reassign name' $ - CS.simpleCall "MemblockAllocDevice" - [Ref $ Var "Ctx", name', size, String $ pretty name'] - - -- Copy Numpy array to the device memory block. - CS.staticMemAlloc $ Unsafe [ - Fixed (Var ptr) (Addr $ Index (Var tmp_arr) $ IdxExp $ Integer 0) - [ ifNotZeroSize size $ - Exp $ CS.simpleCall "CL10.EnqueueWriteBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem name', Bool True - , CS.toIntPtr (Integer 0),CS.toIntPtr size - , CS.toIntPtr $ Var ptr, Integer 0, Null, Null ] - ] - ] - -staticOpenCLArray _ space _ _ = - error $ "CSOpenCL backend cannot create static array in memory space '" ++ space ++ "'" - -memblockFromMem :: CSExp -> CSExp -memblockFromMem mem = Field mem "Mem" - -packArrayOutput :: CS.EntryOutput Imp.OpenCL () -packArrayOutput mem "device" bt ept dims = do - let size = foldr (BinOp "*") (Integer 1) dims' - let bt' = CS.compilePrimTypeToASText bt ept - let nbytes = BinOp "*" (CS.sizeOf bt') size - let createTuple = "createTuple_"++ pretty bt' - - return $ CS.simpleCall createTuple [ memblockFromMem mem, Var "Ctx.OpenCL.Queue", nbytes - , CreateArray (Primitive $ CSInt Int64T) $ Right dims'] - where dims' = map CS.compileDim dims - -packArrayOutput _ sid _ _ _ = - error $ "Cannot return array from " ++ sid ++ " space." - -unpackArrayInput :: CS.EntryInput Imp.OpenCL () -unpackArrayInput mem "device" t _ dims e = do - let size = foldr (BinOp "*") (Integer 1) dims' - let t' = CS.compilePrimTypeToAST t - let nbytes = BinOp "*" (CS.sizeOf t') size - zipWithM_ (CS.unpackDim e) dims [0..] - ptr <- pretty <$> newVName "ptr" - - mem' <- CS.compileVar mem - CS.stm $ CS.getDefaultDecl (Imp.MemParam mem (Imp.Space "device")) - allocateOpenCLBuffer mem' nbytes "device" - CS.stm $ Unsafe [Fixed (Var ptr) (Addr $ Index (Field e "Item1") $ IdxExp $ Integer 0) - [ ifNotZeroSize nbytes $ - Exp $ CS.simpleCall "CL10.EnqueueWriteBuffer" - [ Var "Ctx.OpenCL.Queue", memblockFromMem mem', Bool True - , CS.toIntPtr (Integer 0), CS.toIntPtr nbytes, CS.toIntPtr (Var ptr) - , Integer 0, Null, Null] - ]] - - where dims' = map CS.compileDim dims - -unpackArrayInput _ sid _ _ _ _ = - error $ "Cannot accept array from " ++ sid ++ " space." - -futharkSyncContext :: CSStmt -futharkSyncContext = Exp $ CS.simpleCall "FutharkContextSync" [] - -ifNotZeroSize :: CSExp -> CSStmt -> CSStmt -ifNotZeroSize e s = - If (BinOp "!=" e (Integer 0)) [s] [] - -finishIfSynchronous :: CS.CompilerM op s () -finishIfSynchronous = - CS.stm $ If (Var "Synchronous") [Exp $ CS.simpleCall "CL10.Finish" [Var "Ctx.OpenCL.Queue"]] [] - -newVName' :: MonadFreshNames f => String -> f String -newVName' s = CS.compileName <$> newVName s diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +++ /dev/null @@ -1,376 +0,0 @@ -module Futhark.CodeGen.Backends.CSOpenCL.Boilerplate - ( generateBoilerplate - - , kernelRuntime - , kernelRuns - ) where - -import qualified Data.Map as M - -import Futhark.CodeGen.ImpCode.OpenCL hiding (Index, If, SubExp(..)) -import Futhark.CodeGen.Backends.GenericCSharp as CS -import Futhark.CodeGen.Backends.GenericCSharp.AST as AST -import Futhark.CodeGen.OpenCL.Heuristics -import Futhark.Util (zEncodeString) - -intT, longT, stringT, intArrayT, stringArrayT :: CSType -intT = Primitive $ CSInt Int32T -longT = Primitive $ CSInt Int64T -stringT = Primitive StringT -intArrayT = Composite $ ArrayT intT -stringArrayT = Composite $ ArrayT stringT - -errorMsgNumArgs :: ErrorMsg a -> Int -errorMsgNumArgs = length . errorMsgArgTypes - -formatEscape :: String -> String -formatEscape = concatMap escapeChar - where escapeChar '{' = "{{" - escapeChar '}' = "}}" - escapeChar c = [c] - -failureCase :: Integer -> FailureMsg -> CSStmt -failureCase i (FailureMsg (ErrorMsg parts) backtrace) = - If (BinOp "==" (Var "failure_idx") (Integer i)) - [ let (formatstr, formatargs) = onParts 0 parts - in AST.Assert (AST.Bool False) $ - String (formatstr ++ "\nBacktrace:\n" ++ formatEscape backtrace) : - formatargs - ] - [] - where onParts _ [] = ("", []) - onParts j (ErrorString s : parts') = - let (formatstr, formatargs) = onParts j parts' - in (s ++ formatstr, formatargs) - onParts j (ErrorInt32 _ : parts') = - let (formatstr, formatargs) = onParts (j+1) parts' - in ("{" ++ show j ++ "}" ++ formatstr, Index (Var "args") (IdxExp $ Integer j) : formatargs) - -generateBoilerplate :: String -> String -> M.Map KernelName Safety -> [PrimType] - -> M.Map Name SizeClass - -> [FailureMsg] - -> CS.CompilerM OpenCL () () -generateBoilerplate opencl_code opencl_prelude kernels types sizes failures = do - final_inits <- CS.contextFinalInits - - let (opencl_fields, opencl_inits, top_decls, later_top_decls) = - openClDecls kernels opencl_code opencl_prelude - - CS.stm top_decls - - CS.stm $ AssignTyped stringArrayT (Var "SizeNames") - (Just $ Collection "string[]" (map (String . pretty) $ M.keys sizes)) - - CS.stm $ AssignTyped stringArrayT (Var "SizeVars") - (Just $ Collection "string[]" (map (String . zEncodeString . pretty) $ M.keys sizes)) - - CS.stm $ AssignTyped stringArrayT (Var "SizeClasses") - (Just $ Collection "string[]" (map (String . pretty) $ M.elems sizes)) - - - let get_num_sizes = CS.publicName "GetNumSizes" - let get_size_name = CS.publicName "GetSizeName" - let get_size_class = CS.publicName "GetSizeClass" - - - CS.stm $ CS.privateFunDef get_num_sizes intT [] - [ Return $ (Integer . toInteger) $ M.size sizes ] - CS.stm $ CS.privateFunDef get_size_name (Primitive StringT) [(intT, "i")] - [ Return $ Index (Var "SizeNames") (IdxExp $ Var "i") ] - CS.stm $ CS.privateFunDef get_size_class (Primitive StringT) [(intT, "i")] - [ Return $ Index (Var "SizeClasses") (IdxExp $ Var "i") ] - - let cfg = CS.publicName "ContextConfig" - let new_cfg = CS.publicName "ContextConfigNew" - let cfg_set_debugging = CS.publicName "ContextConfigSetDebugging" - let cfg_set_device = CS.publicName "ContextConfigSetDevice" - let cfg_set_platform = CS.publicName "ContextConfigSetPlatform" - let cfg_dump_program_to = CS.publicName "ContextConfigDumpProgramTo" - let cfg_load_program_from = CS.publicName "ContextConfigLoadProgramFrom" - let cfg_set_default_group_size = CS.publicName "ContextConfigSetDefaultGroupSize" - let cfg_set_default_num_groups = CS.publicName "ContextConfigSetDefaultNumGroups" - let cfg_set_default_tile_size = CS.publicName "ContextConfigSetDefaultTileSize" - let cfg_set_default_threshold = CS.publicName "ContextConfigSetDefaultThreshold" - let cfg_set_size = CS.publicName "ContextConfigSetSize" - - CS.stm $ StructDef "Sizes" (map (\k -> (intT, zEncodeString $ pretty k)) $ M.keys sizes) - CS.stm $ StructDef cfg [ (CustomT "OpenCLConfig", "OpenCL") - , (intArrayT, "Sizes")] - - let tmp_cfg = Var "tmp_cfg" - sizeInit (SizeBespoke _ x) = Integer $ toInteger x - sizeInit _ = Integer 0 - - CS.stm $ CS.privateFunDef new_cfg (CustomT cfg) [] - [ Assign tmp_cfg $ CS.simpleInitClass cfg [] - , Reassign (Field tmp_cfg "Sizes") (Collection "int[]" (map sizeInit (M.elems sizes))) - , Exp $ CS.simpleCall "OpenCLConfigInit" [ Out $ Field tmp_cfg "OpenCL", (Integer . toInteger) $ M.size sizes - , Var "SizeNames", Var "SizeVars", Field tmp_cfg "Sizes", Var "SizeClasses" ] - , Return tmp_cfg - ] - - CS.stm $ CS.privateFunDef cfg_set_debugging VoidT [(RefT $ CustomT cfg, "_cfg"),(Primitive BoolT, "flag")] - [Reassign (Var "_cfg.OpenCL.Debugging") (Var "flag")] - - CS.stm $ CS.privateFunDef cfg_set_device VoidT [(RefT $ CustomT cfg, "_cfg"),(stringT, "s")] - [Exp $ CS.simpleCall "SetPreferredDevice" [Ref $ Var "_cfg.OpenCL", Var "s"]] - - CS.stm $ CS.privateFunDef cfg_set_platform VoidT [(RefT $ CustomT cfg, "_cfg"),(stringT, "s")] - [Exp $ CS.simpleCall "SetPreferredPlatform" [Ref $ Var "_cfg.OpenCL", Var "s"]] - - CS.stm $ CS.privateFunDef cfg_dump_program_to VoidT [(RefT $ CustomT cfg, "_cfg"),(stringT, "path")] - [Reassign (Var "_cfg.OpenCL.DumpProgramTo") (Var "path")] - - CS.stm $ CS.privateFunDef cfg_load_program_from VoidT [(RefT $ CustomT cfg, "_cfg"),(stringT, "path")] - [Reassign (Var "_cfg.OpenCL.LoadProgramFrom") (Var "path")] - - CS.stm $ CS.privateFunDef cfg_set_default_group_size VoidT [(RefT $ CustomT cfg, "_cfg"),(intT, "size")] - [Reassign (Var "_cfg.OpenCL.DefaultGroupSize") (Var "size")] - - CS.stm $ CS.privateFunDef cfg_set_default_num_groups VoidT [(RefT $ CustomT cfg, "_cfg"),(intT, "num")] - [Reassign (Var "_cfg.OpenCL.DefaultNumGroups") (Var "num")] - - - CS.stm $ CS.privateFunDef cfg_set_default_tile_size VoidT [(RefT $ CustomT cfg, "_cfg"),(intT, "size")] - [Reassign (Var "_cfg.OpenCL.DefaultTileSize") (Var "size")] - - CS.stm $ CS.privateFunDef cfg_set_default_threshold VoidT [(RefT $ CustomT cfg, "_cfg"),(intT, "size")] - [Reassign (Var "_cfg.OpenCL.DefaultThreshold") (Var "size")] - - CS.stm $ CS.privateFunDef cfg_set_size (Primitive BoolT) [(RefT $ CustomT cfg, "_cfg") - , (stringT, "SizeName") - , (intT, "SizeValue")] - [ AST.For "i" ((Integer . toInteger) $ M.size sizes) - [ If (BinOp "==" (Var "SizeName") (Index (Var "SizeNames") (IdxExp (Var "i")))) - [ Reassign (Index (Var "_cfg.Sizes") (IdxExp (Var "i"))) (Var "SizeValue") - , Return (AST.Bool True)] [] - ] - , Return $ AST.Bool False ] - - - let ctx_ = CS.publicName "Context" - let new_ctx = CS.publicName "ContextNew" - let sync_ctx = CS.publicName "ContextSync" - - CS.stm $ StructDef ctx_ $ - [ (Primitive IntPtrT, "NULL") - , (CustomT "CLMemoryHandle", "EMPTY_MEM_HANDLE") - , (CustomT "OpenCLFreeList", "FreeList") - , (Primitive $ CSInt Int64T, "CurrentMemUsageDevice") - , (Primitive $ CSInt Int64T, "PeakMemUsageDevice") - , (Primitive BoolT, "DetailMemory") - , (Primitive BoolT, "Debugging") - , (CustomT "CLMemoryHandle", "GlobalFailure") - , (intT, "GlobalFailureIsAnOption") - , (CustomT "CLMemoryHandle", "GlobalFailureArgs") - , (CustomT "OpenCLContext", "OpenCL") - , (CustomT "Sizes", "Sizes") ] - ++ opencl_fields - - mapM_ CS.stm later_top_decls - - CS.addMemberDecl $ AssignTyped (CustomT cfg) (Var "Cfg") Nothing - CS.addMemberDecl $ AssignTyped (CustomT ctx_) (Var "Ctx") Nothing - - CS.beforeParse $ Reassign (Var "Cfg") $ CS.simpleCall new_cfg [] - CS.atInit $ Exp $ CS.simpleCall new_ctx [Var "Cfg"] - CS.atInit $ Reassign (Var "Ctx.EMPTY_MEM_HANDLE") $ CS.simpleCall "EmptyMemHandle" [Var "Ctx.OpenCL.Context"] - CS.atInit $ Reassign (Var "Ctx.FreeList") $ CS.simpleCall "OpenCLFreeListInit" [] - - CS.addMemberDecl $ AssignTyped (Primitive BoolT) (Var "Synchronous") (Just $ AST.Bool False) - - let set_required_types = [Reassign (Var "RequiredTypes") (AST.Bool True) - | FloatType Float64 `elem` types] - - set_sizes = zipWith (\i k -> Reassign (Field (Var "Ctx.Sizes") (zEncodeString $ pretty k)) - (Index (Var "Cfg.Sizes") (IdxExp $ (Integer . toInteger) i))) - [(0::Int)..] $ M.keys sizes - max_failure_args = - foldl max 0 $ map (errorMsgNumArgs . failureError) failures - - CS.stm $ CS.privateFunDef new_ctx VoidT [(CustomT cfg, "Cfg")] $ - [ AssignTyped (CustomT "ComputeErrorCode") (Var "error") Nothing - , Reassign (Var "Ctx.DetailMemory") (Var "Cfg.OpenCL.Debugging") - , Reassign (Var "Ctx.Debugging") (Var "Cfg.OpenCL.Debugging") - , Reassign (Var "Ctx.OpenCL.Cfg") (Var "Cfg.OpenCL")] - ++ opencl_inits ++ - [ Assign (Var "RequiredTypes") (AST.Bool False) ] - ++ set_required_types ++ - [ AssignTyped (CustomT "CLProgramHandle") (Var "prog") - (Just $ CS.simpleCall "SetupOpenCL" [ Ref $ Var "Ctx" - , Var "OpenCLProgram" - , Var "RequiredTypes"])] ++ - [ Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 0) - , Unsafe - [ Exp $ CS.simpleCall "OPENCL_SUCCEED" - [CS.simpleCall "OpenCLAllocActual" [ Ref $ Var "Ctx" - , Integer 4 - , Ref $ Var "Ctx.GlobalFailure"]] - , AssignTyped intT (Var "no_failure") (Just (Integer (-1))) - , Exp $ CS.simpleCall "OPENCL_SUCCEED" - [CS.simpleCall "CL10.EnqueueWriteBuffer" - [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailure", AST.Bool True - , CS.toIntPtr $ Integer 0 - , CS.toIntPtr $ Integer 4 - , CS.toIntPtr $ Addr (Var "no_failure") - , Integer 0, Null, Null]] - - , Exp $ CS.simpleCall "OPENCL_SUCCEED" - [CS.simpleCall "OpenCLAllocActual" [ Ref $ Var "Ctx" - , Integer $ toInteger $ 4 * (max_failure_args + 1) - , Ref $ Var "Ctx.GlobalFailureArgs"]]]] - ++ concatMap loadKernel (M.toList kernels) - ++ final_inits - ++ set_sizes - - CS.stm $ CS.privateFunDef sync_ctx VoidT [] - [ AssignTyped intT (Var "failure_idx") (Just $ CS.simpleInitClass (pretty intT) []) - , Unsafe [ CS.assignScalarPointer (Var "failure_idx") (Var "ptr") - , Reassign (Var "Ctx.GlobalFailureIsAnOption") (Integer 0) - , Exp $ CS.simpleCall "OPENCL_SUCCEED" [ - CS.simpleCall "CL10.EnqueueReadBuffer" - [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailure", AST.Bool True - , CS.toIntPtr $ Integer 0 - , CS.toIntPtr $ Integer 4 - , CS.toIntPtr $ Var "ptr" - , Integer 0, Null, Null] - ] - ] - - , If (BinOp "!=" (Var "failure_idx") (Integer (-1))) - ([ AssignTyped intArrayT (Var "args") $ Just $ CreateArray intT $ - Left $ max_failure_args + 1 - , Unsafe [ - Fixed (Var "ptr") (Addr (Index (Var "args") $ IdxExp $ Integer 0)) - [Exp $ CS.simpleCall "CL10.EnqueueReadBuffer" - [ Var "Ctx.OpenCL.Queue", Var "Ctx.GlobalFailureArgs", AST.Bool True - , CS.toIntPtr $ Integer 0 - , CS.toIntPtr $ Integer $ toInteger $ 4 * max_failure_args - , CS.toIntPtr $ Var "ptr" - , Integer 0, Null, Null]]]] ++ - zipWith failureCase [0..] failures) - [] - ] - - CS.debugReport $ openClReport $ M.keys kernels - - -openClDecls :: M.Map KernelName Safety -> String -> String - -> ([(CSType, String)], [CSStmt], CSStmt, [CSStmt]) -openClDecls kernels opencl_program opencl_prelude = - (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load) - where ctx_fields = - [ (intT, "TotalRuns") - , (Primitive $ CSInt Int64T, "TotalRuntime")] - ++ concatMap (\name -> [(CustomT "CLKernelHandle", name) - ,(longT, kernelRuntime name) - ,(intT, kernelRuns name)]) - (M.keys kernels) - - ctx_inits = - [ Reassign (Var $ ctx "TotalRuns") (Integer 0) - , Reassign (Var $ ctx "TotalRuntime") (Integer 0) ] - ++ concatMap (\name -> [ Reassign (Var $ (ctx . kernelRuntime) name) (Integer 0) - , Reassign (Var $ (ctx . kernelRuns) name) (Integer 0)]) - (M.keys kernels) - - - futhark_context = CS.publicName "Context" - - openCL_load = [CS.privateFunDef "PostOpenCLSetup" VoidT - [ (RefT $ CustomT futhark_context, "Ctx") - , (RefT $ CustomT "OpenCLDeviceOption", "Option")] $ map sizeHeuristicsCode sizeHeuristicsTable] - - openCL_boilerplate = - AssignTyped stringArrayT (Var "OpenCLProgram") - (Just $ Collection "string[]" [String $ opencl_prelude ++ opencl_program]) - -loadKernel :: (String, Safety) -> [CSStmt] -loadKernel (name, _) = - [ Reassign (Var $ ctx name) - (CS.simpleCall "CL10.CreateKernel" [Var "prog", String name, Out $ Var "error"]) - , AST.Assert (BinOp "==" (Var "error") (Integer 0)) [] - , If (Var "Ctx.Debugging") - [Exp $ consoleErrorWriteLine "Created kernel {0}" [Var $ ctx name]] - [] - ] - -kernelRuntime :: String -> String -kernelRuntime = (++"_TotalRuntime") - -kernelRuns :: String -> String -kernelRuns = (++"_Runs") - -openClReport :: [String] -> CSStmt -openClReport names = - If (Var "Ctx.Debugging") (report_kernels ++ [report_total]) [] - where longest_name = foldl max 0 $ map length names - report_kernels = map reportKernel names - format_string name = - let padding = replicate (longest_name - length name) ' ' - in unwords ["Kernel", - name ++ padding, - "executed {0} times, with average runtime: {1}\tand total runtime: {2}"] - reportKernel name = - let runs = ctx $ kernelRuns name - total_runtime = ctx $ kernelRuntime name - in If (BinOp "!=" (Var runs) (Integer 0)) - [Exp $ consoleErrorWriteLine (format_string name) - [ Var runs - , Ternary (BinOp "!=" - (BinOp "/" - (Cast (Primitive $ CSInt Int64T) (Var total_runtime)) - (Var runs)) - (Integer 0)) - (Var runs) (Integer 1) - , Cast (Primitive $ CSInt Int64T) $ Var total_runtime] - , AssignOp "+" (Var $ ctx "TotalRuntime") (Var total_runtime) - , AssignOp "+" (Var $ ctx "TotalRuns") (Var runs) - ] [] - - ran_text = "Ran {0} kernels with cumulative runtime: {1}" - report_total = Exp $ consoleErrorWriteLine ran_text [ Var $ ctx "TotalRuns" - , Var $ ctx "TotalRuntime"] - -sizeHeuristicsCode :: SizeHeuristic -> CSStmt -sizeHeuristicsCode (SizeHeuristic platform_name device_type which what) = - let which'' = BinOp "==" which' (Integer 0) - option_contains_platform_name = CS.simpleCall "Option.PlatformName.Contains" [String platform_name] - option_contains_device_type = BinOp "==" (Var "Option.DeviceType") (Var $ clDeviceType device_type) - in If (BinOp "&&" which'' - (BinOp "&&" option_contains_platform_name - option_contains_device_type)) - [ get_size ] [] - - where clDeviceType DeviceGPU = "ComputeDeviceTypes.Gpu" - clDeviceType DeviceCPU = "ComputeDeviceTypes.Cpu" - - which' = case which of - LockstepWidth -> Var "Ctx.OpenCL.LockstepWidth" - NumGroups -> Var "Ctx.OpenCL.Cfg.DefaultNumGroups" - GroupSize -> Var "Ctx.OpenCL.Cfg.DefaultGroupSize" - TileSize -> Var "Ctx.OpenCL.Cfg.DefaultTileSize" - Threshold -> Var "Ctx.OpenCL.Cfg.DefaultThreshold" - - get_size = case what of - HeuristicConst x -> - Reassign which' (Integer $ toInteger x) - - HeuristicDeviceInfo _ -> - -- This only works for device info that fits in the variable. - Unsafe - [ - Fixed (Var "ptr") (Addr which') - [ - Exp $ CS.simpleCall "CL10.GetDeviceInfo" - [ Var "Ctx.OpenCL.Device", Var "ComputeDeviceInfo.MaxComputeUnits" - , CS.simpleCall "new IntPtr" [CS.simpleCall "Marshal.SizeOf" [which']] - , CS.toIntPtr $ Var "ptr", Out ctxNULL ] - ] - ] - -ctx :: String -> String -ctx = (++) "Ctx." - -ctxNULL :: CSExp -ctxNULL = Var "Ctx.NULL" 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 @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Trustworthy #-} @@ -15,6 +16,7 @@ , defaultOperations , OpCompiler , ErrorCompiler + , CallCompiler , PointerQuals , MemoryType @@ -45,6 +47,7 @@ , compileExpToName , rawMem , item + , items , stm , stms , decl @@ -93,8 +96,7 @@ data CompilerState s = CompilerState { - compTypeStructs :: [([Type], (C.Type, C.Definition))] - , compArrayStructs :: [((C.Type, Int), (C.Type, [C.Definition]))] + compArrayStructs :: [((C.Type, Int), (C.Type, [C.Definition]))] , compOpaqueStructs :: [(String, (C.Type, [C.Definition]))] , compEarlyDecls :: DL.DList C.Definition , compInit :: [C.Stm] @@ -102,14 +104,13 @@ , compUserState :: s , compHeaderDecls :: M.Map HeaderSection (DL.DList C.Definition) , compLibDecls :: DL.DList C.Definition - , compCtxFields :: DL.DList (String, C.Type, Maybe C.Exp) + , compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp) , compProfileItems :: DL.DList C.BlockItem , compDeclaredMem :: [(VName,Space)] } newCompilerState :: VNameSource -> s -> CompilerState s -newCompilerState src s = CompilerState { compTypeStructs = [] - , compArrayStructs = [] +newCompilerState src s = CompilerState { compArrayStructs = [] , compOpaqueStructs = [] , compEarlyDecls = mempty , compInit = [] @@ -173,6 +174,9 @@ C.Exp -> CompilerM op s () +-- | Call a function. +type CallCompiler op s = [VName] -> Name -> [C.Exp] -> CompilerM op s () + data Operations op s = Operations { opsWriteScalar :: WriteScalar op s , opsReadScalar :: ReadScalar op s @@ -184,6 +188,7 @@ , opsMemoryType :: MemoryType op s , opsCompiler :: OpCompiler op s , opsError :: ErrorCompiler op s + , opsCall :: CallCompiler op s , opsFatMemory :: Bool -- ^ If true, use reference counting. Otherwise, bare @@ -197,11 +202,21 @@ onPart (ErrorInt32 x) = ("%d",) <$> compileExp x (formatstrs, formatargs) <- unzip <$> mapM onPart parts let formatstr = "Error: " ++ concat formatstrs ++ "\n\nBacktrace:\n%s" - stm [C.cstm|{ ctx->error = msgprintf($string:formatstr, $args:formatargs, $string:stacktrace); - $items:free_all_mem - return 1; - }|] + items [C.citems|ctx->error = msgprintf($string:formatstr, $args:formatargs, $string:stacktrace); + $items:free_all_mem + return 1;|] +defCall :: CallCompiler op s +defCall dests fname args = do + let out_args = [ [C.cexp|&$id:d|] | d <- dests ] + args' | isBuiltInFunction fname = args + | otherwise = [C.cexp|ctx|] : out_args ++ args + case dests of + [dest] | isBuiltInFunction fname -> + stm [C.cstm|$id:dest = $id:(funName fname)($args:args');|] + _ -> + item [C.citem|if ($id:(funName fname)($args:args') != 0) { err = 1; goto cleanup; }|] + -- | A set of operations that fail for every operation involving -- non-default memory spaces. Uses plain pointers and @malloc@ for -- memory management. @@ -216,6 +231,7 @@ , opsCompiler = defCompiler , opsFatMemory = True , opsError = defError + , opsCall = defCall } where defWriteScalar _ _ _ _ _ = error "Cannot write to non-default memory space because I am dumb" @@ -286,8 +302,7 @@ envFatMemory :: CompilerEnv op s -> Bool envFatMemory = opsFatMemory . envOperations -tupleDefinitions, arrayDefinitions, opaqueDefinitions :: CompilerState s -> [C.Definition] -tupleDefinitions = map (snd . snd) . compTypeStructs +arrayDefinitions, opaqueDefinitions :: CompilerState s -> [C.Definition] arrayDefinitions = concatMap (snd . snd) . compArrayStructs opaqueDefinitions = concatMap (snd . snd) . compOpaqueStructs @@ -357,6 +372,9 @@ item :: C.BlockItem -> CompilerM op s () item x = tell $ mempty { accItems = DL.singleton x } +items :: [C.BlockItem] -> CompilerM op s () +items = mapM_ item + fatMemory :: Space -> CompilerM op s Bool fatMemory ScalarSpace{} = return False fatMemory _ = asks envFatMemory @@ -425,7 +443,7 @@ earlyDecl def = modify $ \s -> s { compEarlyDecls = compEarlyDecls s <> DL.singleton def } -contextField :: String -> C.Type -> Maybe C.Exp -> CompilerM op s () +contextField :: C.Id -> C.Type -> Maybe C.Exp -> CompilerM op s () contextField name ty initial = modify $ \s -> s { compCtxFields = compCtxFields s <> DL.singleton (name,ty,initial) } @@ -434,8 +452,6 @@ s { compProfileItems = compProfileItems s <> DL.singleton x } stm :: C.Stm -> CompilerM op s () -stm (C.Block items _) = mapM_ item items -stm (C.Default s _) = stm s stm s = item [C.citem|$stm:s|] stms :: [C.Stm] -> CompilerM op s () @@ -539,8 +555,8 @@ if (block->references != NULL) { *(block->references) -= 1; if (ctx->detail_memory) { - fprintf(stderr, $string:("Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n"), - desc, block->desc, $string:spacedesc, *(block->references)); + fprintf(stderr, "Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n", + desc, block->desc, $string:spacedesc, *(block->references)); } if (*(block->references) == 0) { ctx->$id:usagename -= block->size; @@ -611,10 +627,10 @@ else [C.citem|str_builder(&builder, $string:peakmsg, (long long) ctx->$id:peakname);|]) where mty = fatMemType space (peakname, usagename, sname, spacedesc) = case space of - Space sid -> ("peak_mem_usage_" ++ sid, - "cur_mem_usage_" ++ sid, - "memblock_" ++ sid, - "space '" ++ sid ++ "'") + Space sid -> (C.toIdent ("peak_mem_usage_" ++ sid) noLoc, + C.toIdent ("cur_mem_usage_" ++ sid) noLoc, + C.toIdent ("memblock_" ++ sid) noLoc, + "space '" ++ sid ++ "'") _ -> ("peak_mem_usage_default", "cur_mem_usage_default", "memblock", @@ -647,7 +663,17 @@ $string:src_s) != 0) { return 1; }|] - else stm [C.cstm|$exp:dest = $exp:src;|] + else case space of + ScalarSpace ds _ -> do + i' <- newVName "i" + let i = C.toIdent i' + it = primTypeToCType $ IntType Int32 + ds' = map (`C.toExp` noLoc) ds + bound = cproduct ds' + stm [C.cstm|for ($ty:it $id:i = 0; $id:i < $exp:bound; $id:i++) { + $exp:dest[$id:i] = $exp:src[$id:i]; + }|] + _ -> stm [C.cstm|$exp:dest = $exp:src;|] unRefMem :: C.ToExp a => a -> Space -> CompilerM op s () unRefMem mem space = do @@ -720,9 +746,11 @@ iter x = ((x::Word32) `shiftR` 16) `xor` x criticalSection :: [C.BlockItem] -> [C.BlockItem] -criticalSection items = [[C.citem|lock_lock(&ctx->lock);|]] <> - items <> - [[C.citem|lock_unlock(&ctx->lock);|]] +criticalSection x = [C.citems| + lock_lock(&ctx->lock); + $items:x + lock_unlock(&ctx->lock); + |] arrayLibraryFunctions :: Space -> PrimType -> Signedness -> [DimSize] -> CompilerM op s [C.Definition] @@ -1084,7 +1112,7 @@ write_array(stdout, binary_output, &$exp:(primTypeInfo bt ept), arr, $id:shape_array(ctx, $exp:e), $int:rank); free(arr); - }|] + }|] where rank = length shape bt' = primTypeToCType bt name = arrayName bt ept rank @@ -1126,7 +1154,7 @@ new_array <- publicName $ "new_" ++ name free_array <- publicName $ "free_" ++ name - stm [C.cstm|{ + items [C.citems| typename int64_t $id:shape[$int:rank]; $ty:t' *$id:arr = NULL; errno = 0; @@ -1140,8 +1168,7 @@ $string:dims_s, $exp:(primTypeInfo t ept).type_name, strerror(errno)); - } - }|] + }|] return ([C.cstm|assert(($exp:dest = $id:new_array(ctx, $id:arr, $args:dims_exps)) != 0);|], [C.cstm|assert($id:free_array(ctx, $exp:dest) == 0);|], @@ -1225,6 +1252,7 @@ long int elapsed_usec = t_end - t_start; if (time_runs && runtime_file != NULL) { fprintf(runtime_file, "%lld\n", (long long) elapsed_usec); + fflush(runtime_file); } $stms:free_input |] @@ -1349,14 +1377,15 @@ -- | Compile imperative program to a C program. Always uses the -- function named "main" as entry point, so make sure it is defined. compileProg :: MonadFreshNames m => - Operations op () + String + -> Operations op () -> CompilerM op () () -> String -> [Space] -> [Option] -> Definitions op -> m CParts -compileProg ops extra header_extra spaces options prog = do +compileProg backend ops extra header_extra spaces options prog = do src <- getNameSource let ((prototypes, definitions, entry_points), endstate) = runCompilerM ops src () compileProg' @@ -1385,6 +1414,7 @@ $esc:("\n// Miscellaneous\n") $edecls:(miscDecls endstate) +$esc:("#define FUTHARK_BACKEND_"++backend) |] let utildefs = [C.cunit| @@ -1521,8 +1551,6 @@ $edecls:lib_decls -$edecls:(tupleDefinitions endstate) - $edecls:(map funcToDef definitions) $edecls:(arrayDefinitions endstate) @@ -1541,8 +1569,11 @@ get_consts <- compileConstants consts - (prototypes, definitions) <- unzip <$> mapM (compileFun get_consts) funs + ctx_ty <- contextType + (prototypes, definitions) <- + unzip <$> mapM (compileFun get_consts [[C.cparam|$ty:ctx_ty *ctx|]]) funs + mapM_ earlyDecl memstructs entry_points <- mapM (uncurry onEntryPoint) $ filter (functionEntry . snd) funs @@ -1696,19 +1727,16 @@ local lexMem $ f (concatMap declCached cached') (map freeCached cached') -compileFun :: [C.BlockItem] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func) -compileFun get_constants (fname, func@(Function _ outputs inputs body _ _)) = do +compileFun :: [C.BlockItem] -> [C.Param] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func) +compileFun get_constants extra (fname, func@(Function _ outputs inputs body _ _)) = do (outparams, out_ptrs) <- unzip <$> mapM compileOutput outputs inparams <- mapM compileInput inputs cachingMemory (lexicalMemoryUsage func) $ \decl_cached free_cached -> do body' <- blockScope $ compileFunBody out_ptrs outputs body - ctx_ty <- contextType - return ([C.cedecl|static int $id:(funName fname)($ty:ctx_ty *ctx, - $params:outparams, $params:inparams);|], - [C.cfun|static int $id:(funName fname)($ty:ctx_ty *ctx, - $params:outparams, $params:inparams) { + return ([C.cedecl|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams);|], + [C.cfun|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams) { int err = 0; $items:decl_cached $items:get_constants @@ -1912,10 +1940,10 @@ compileCode Skip = return () compileCode (Comment s code) = do - items <- blockScope $ compileCode code + xs <- blockScope $ compileCode code let comment = "// " ++ s stm [C.cstm|$comment:comment - { $items:items } + { $items:xs } |] compileCode (DebugPrint s (Just e)) = do @@ -2058,7 +2086,7 @@ ArrayZeros n -> earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] -- Fake a memory block. - contextField (pretty name) + contextField (C.toIdent name noLoc) [C.cty|struct memblock|] $ Just [C.cexp|(struct memblock){NULL, (char*)$id:name_realtype, 0}|] item [C.citem|struct memblock $id:name = ctx->$id:name;|] @@ -2082,16 +2110,9 @@ compileCode (SetMem dest src space) = setMem dest src space -compileCode (Call dests fname args) = do - args' <- mapM compileArg args - let out_args = [ [C.cexp|&$id:d|] | d <- dests ] - args'' | isBuiltInFunction fname = args' - | otherwise = [C.cexp|ctx|] : out_args ++ args' - case dests of - [dest] | isBuiltInFunction fname -> - stm [C.cstm|$id:dest = $id:(funName fname)($args:args'');|] - _ -> - item [C.citem|if ($id:(funName fname)($args:args'') != 0) { err = 1; goto cleanup; }|] +compileCode (Call dests fname args) = + join $ asks (opsCall . envOperations) + <*> pure dests <*> pure fname <*> mapM compileArg args where compileArg (MemArg m) = return [C.cexp|$exp:m|] compileArg (ExpArg e) = compileExp e @@ -2101,14 +2122,14 @@ blockScope' :: CompilerM op s a -> CompilerM op s (a, [C.BlockItem]) blockScope' m = do old_allocs <- gets compDeclaredMem - (x, items) <- pass $ do + (x, xs) <- pass $ do (x, w) <- listen m - let items = DL.toList $ accItems w - return ((x, items), const mempty) + let xs = DL.toList $ accItems w + return ((x, xs), const mempty) new_allocs <- gets $ filter (`notElem` old_allocs) . compDeclaredMem modify $ \s -> s { compDeclaredMem = old_allocs } releases <- collect $ mapM_ (uncurry unRefMem) new_allocs - return (x, items <> releases) + return (x, xs <> releases) compileFunBody :: [C.Exp] -> [Param] -> Code op -> CompilerM op s () compileFunBody output_ptrs outputs code = do diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp.hs b/src/Futhark/CodeGen/Backends/GenericCSharp.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/GenericCSharp.hs +++ /dev/null @@ -1,1403 +0,0 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, LambdaCase #-} -{-# LANGUAGE TupleSections #-} --- | A generic C# code generator which is polymorphic in the type --- of the operations. Concretely, we use this to handle both --- sequential and OpenCL C# code. -module Futhark.CodeGen.Backends.GenericCSharp - ( compileProg - , Constructor (..) - , emptyConstructor - - , assignScalarPointer - , toIntPtr - , compileName - , compileVar - , compileDim - , compileExp - , compileCode - , compilePrimValue - , compilePrimType - , compilePrimTypeExt - , compilePrimTypeToAST - , compilePrimTypeToASText - , contextFinalInits - , debugReport - - , Operations (..) - , defaultOperations - - , unpackDim - - , CompilerM (..) - , OpCompiler - , WriteScalar - , ReadScalar - , Allocate - , Copy - , StaticArray - , EntryOutput - , EntryInput - - , CompilerEnv(..) - , CompilerState(..) - , CompilerAcc - , stm - , stms - , atInit - , staticMemDecl - , staticMemAlloc - , addMemberDecl - , beforeParse - , collect' - , collect - , simpleCall - , callMethod - , simpleInitClass - - , copyMemoryDefaultSpace - , consoleErrorWrite - , consoleErrorWriteLine - - , publicName - , sizeOf - , privateFunDef - , getDefaultDecl - ) where - -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS -import Control.Arrow((&&&)) -import Data.Maybe -import qualified Data.Map as M - -import Futhark.IR.Primitive hiding (Bool) -import Futhark.MonadFreshNames -import Futhark.IR.Syntax (Space(..)) -import qualified Futhark.CodeGen.ImpCode as Imp -import Futhark.CodeGen.Backends.GenericCSharp.AST -import Futhark.CodeGen.Backends.GenericCSharp.Options -import Futhark.CodeGen.Backends.GenericCSharp.Definitions -import Futhark.Util (zEncodeString) - --- | A substitute expression compiler, tried before the main --- compilation function. -type OpCompiler op s = op -> CompilerM op s () - --- | Write a scalar to the given memory block with the given index and --- in the given memory space. -type WriteScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId -> CSExp - -> CompilerM op s () - --- | Read a scalar from the given memory block with the given index and --- in the given memory space. -type ReadScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId - -> CompilerM op s CSExp - --- | Allocate a memory block of the given size in the given memory --- space, saving a reference in the given variable name. -type Allocate op s = CSExp -> CSExp -> Imp.SpaceId - -> CompilerM op s () - --- | Copy from one memory block to another. -type Copy op s = CSExp -> CSExp -> Imp.Space -> - CSExp -> CSExp -> Imp.Space -> - CSExp -> PrimType -> - CompilerM op s () - --- | Create a static array of values - initialised at load time. -type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> Imp.ArrayContents -> CompilerM op s () - --- | Construct the C# array being returned from an entry point. -type EntryOutput op s = CSExp -> Imp.SpaceId -> - PrimType -> Imp.Signedness -> - [Imp.DimSize] -> - CompilerM op s CSExp - --- | Unpack the array being passed to an entry point. -type EntryInput op s = VName -> Imp.SpaceId -> - PrimType -> Imp.Signedness -> - [Imp.DimSize] -> - CSExp -> - CompilerM op s () - -data Operations op s = Operations { opsWriteScalar :: WriteScalar op s - , opsReadScalar :: ReadScalar op s - , opsAllocate :: Allocate op s - , opsCopy :: Copy op s - , opsStaticArray :: StaticArray op s - , opsCompiler :: OpCompiler op s - , opsEntryOutput :: EntryOutput op s - , opsEntryInput :: EntryInput op s - , opsSyncRun :: CSStmt - } - --- | A set of operations that fail for every operation involving --- non-default memory spaces. Uses plain pointers and @malloc@ for --- memory management. -defaultOperations :: Operations op s -defaultOperations = Operations { opsWriteScalar = defWriteScalar - , opsReadScalar = defReadScalar - , opsAllocate = defAllocate - , opsCopy = defCopy - , opsStaticArray = defStaticArray - , opsCompiler = defCompiler - , opsEntryOutput = defEntryOutput - , opsEntryInput = defEntryInput - , opsSyncRun = defSyncRun - } - where defWriteScalar _ _ _ _ _ = - error "Cannot write to non-default memory space because I am dumb" - defReadScalar _ _ _ _ = - error "Cannot read from non-default memory space" - defAllocate _ _ _ = - error "Cannot allocate in non-default memory space" - defCopy _ _ _ _ _ _ _ _ = - error "Cannot copy to or from non-default memory space" - defStaticArray _ _ _ _ = - error "Cannot create static array in non-default memory space" - defCompiler _ = - error "The default compiler cannot compile extended operations" - defEntryOutput _ _ _ _ = - error "Cannot return array not in default memory space" - defEntryInput _ _ _ _ = - error "Cannot accept array not in default memory space" - defSyncRun = - Pass - -data CompilerEnv op s = CompilerEnv - { envOperations :: Operations op s - , envVarExp :: M.Map VName CSExp - } - -data CompilerAcc op s = CompilerAcc { - accItems :: [CSStmt] - , accFreedMem :: [VName] - } - -instance Semigroup (CompilerAcc op s) where - CompilerAcc items1 freed1 <> CompilerAcc items2 freed2 = - CompilerAcc (items1<>items2) (freed1<>freed2) - -instance Monoid (CompilerAcc op s) where - mempty = CompilerAcc mempty mempty - -envOpCompiler :: CompilerEnv op s -> OpCompiler op s -envOpCompiler = opsCompiler . envOperations - -envReadScalar :: CompilerEnv op s -> ReadScalar op s -envReadScalar = opsReadScalar . envOperations - -envWriteScalar :: CompilerEnv op s -> WriteScalar op s -envWriteScalar = opsWriteScalar . envOperations - -envAllocate :: CompilerEnv op s -> Allocate op s -envAllocate = opsAllocate . envOperations - -envCopy :: CompilerEnv op s -> Copy op s -envCopy = opsCopy . envOperations - -envStaticArray :: CompilerEnv op s -> StaticArray op s -envStaticArray = opsStaticArray . envOperations - -envEntryOutput :: CompilerEnv op s -> EntryOutput op s -envEntryOutput = opsEntryOutput . envOperations - -envEntryInput :: CompilerEnv op s -> EntryInput op s -envEntryInput = opsEntryInput . envOperations - -envSyncFun :: CompilerEnv op s -> CSStmt -envSyncFun = opsSyncRun . envOperations - -newCompilerEnv :: Operations op s -> CompilerEnv op s -newCompilerEnv ops = - CompilerEnv { envOperations = ops - , envVarExp = mempty } - -data CompilerState s = CompilerState { - compNameSrc :: VNameSource - , compBeforeParse :: [CSStmt] - , compInit :: [CSStmt] - , compStaticMemDecls :: [CSStmt] - , compStaticMemAllocs :: [CSStmt] - , compDebugItems :: [CSStmt] - , compUserState :: s - , compMemberDecls :: [CSStmt] - , compAssignedVars :: [VName] - , compDeclaredMem :: [(CSExp, Space)] -} - -newCompilerState :: VNameSource -> s -> CompilerState s -newCompilerState src s = CompilerState { compNameSrc = src - , compBeforeParse = [] - , compInit = [] - , compStaticMemDecls = [] - , compStaticMemAllocs = [] - , compDebugItems = [] - , compMemberDecls = [] - , compUserState = s - , compAssignedVars = [] - , compDeclaredMem = [] - } - -newtype CompilerM op s a = CompilerM (RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a) - deriving (Functor, Applicative, Monad, - MonadState (CompilerState s), - MonadReader (CompilerEnv op s), - MonadWriter (CompilerAcc op s)) - -instance MonadFreshNames (CompilerM op s) where - getNameSource = gets compNameSrc - putNameSource src = modify $ \s -> s { compNameSrc = src } - -collect :: CompilerM op s () -> CompilerM op s [CSStmt] -collect m = pass $ do - ((), w) <- listen m - return (accItems w, - const w { accItems = mempty} ) - -collect' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) -collect' m = pass $ do - (x, w) <- listen m - return ((x, accItems w), - const w { accItems = mempty}) - -beforeParse :: CSStmt -> CompilerM op s () -beforeParse x = modify $ \s -> - s { compBeforeParse = compBeforeParse s ++ [x] } - -atInit :: CSStmt -> CompilerM op s () -atInit x = modify $ \s -> - s { compInit = compInit s ++ [x] } - -staticMemDecl :: CSStmt -> CompilerM op s () -staticMemDecl x = modify $ \s -> - s { compStaticMemDecls = compStaticMemDecls s ++ [x] } - -staticMemAlloc :: CSStmt -> CompilerM op s () -staticMemAlloc x = modify $ \s -> - s { compStaticMemAllocs = compStaticMemAllocs s ++ [x] } - -addMemberDecl :: CSStmt -> CompilerM op s () -addMemberDecl x = modify $ \s -> - s { compMemberDecls = compMemberDecls s ++ [x] } - -contextFinalInits :: CompilerM op s [CSStmt] -contextFinalInits = gets compInit - -item :: CSStmt -> CompilerM op s () -item x = tell $ mempty { accItems = [x] } - -stm :: CSStmt -> CompilerM op s () -stm = item - -stms :: [CSStmt] -> CompilerM op s () -stms = mapM_ stm - -debugReport :: CSStmt -> CompilerM op s () -debugReport x = modify $ \s -> - s { compDebugItems = compDebugItems s ++ [x] } - -getVarAssigned :: VName -> CompilerM op s Bool -getVarAssigned vname = - gets $ elem vname . compAssignedVars - -setVarAssigned :: VName -> CompilerM op s () -setVarAssigned vname = modify $ \s -> - s { compAssignedVars = vname : compAssignedVars s} - -futharkFun :: String -> String -futharkFun s = "futhark_" ++ zEncodeString s - -paramType :: Imp.Param -> Imp.Type -paramType (Imp.MemParam _ space) = Imp.Mem space -paramType (Imp.ScalarParam _ t) = Imp.Scalar t - -compileOutput :: Imp.Param -> (CSExp, CSType) -compileOutput = nameFun &&& typeFun - where nameFun = Var . compileName . Imp.paramName - typeFun = compileType . paramType - -getDefaultDecl :: Imp.Param -> CSStmt -getDefaultDecl (Imp.MemParam v DefaultSpace) = - Assign (Var $ compileName v) $ simpleCall "allocateMem" [Integer 0] -getDefaultDecl (Imp.MemParam v _) = - AssignTyped (CustomT "OpenCLMemblock") (Var $ compileName v) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"]) -getDefaultDecl (Imp.ScalarParam v Cert) = - Assign (Var $ compileName v) $ Bool True -getDefaultDecl (Imp.ScalarParam v t) = - Assign (Var $ compileName v) $ simpleInitClass (compilePrimType t) [] - -runCompilerM :: Operations op s - -> VNameSource - -> s - -> CompilerM op s a - -> a -runCompilerM ops src userstate (CompilerM m) = - fst $ evalRWS m (newCompilerEnv ops) (newCompilerState src userstate) - -standardOptions :: [Option] -standardOptions = [ - Option { optionLongName = "write-runtime-to" - , optionShortName = Just 't' - , optionArgument = RequiredArgument - , optionAction = - [ - If (BinOp "!=" (Var "RuntimeFile") Null) - [Exp $ simpleCall "RuntimeFile.Close" []] [] - , Reassign (Var "RuntimeFile") $ - simpleInitClass "FileStream" [Var "optarg", Var "FileMode.Create"] - , Reassign (Var "RuntimeFileWriter") $ - simpleInitClass "StreamWriter" [Var "RuntimeFile"] - ] - }, - Option { optionLongName = "runs" - , optionShortName = Just 'r' - , optionArgument = RequiredArgument - , optionAction = - [ Reassign (Var "NumRuns") $ simpleCall "Convert.ToInt32" [Var "optarg"] - , Reassign (Var "DoWarmupRun") $ Bool True - ] - }, - Option { optionLongName = "entry-point" - , optionShortName = Just 'e' - , optionArgument = RequiredArgument - , optionAction = - [ Reassign (Var "EntryPoint") $ Var "optarg" ] - } - ] - --- | The class generated by the code generator must have a --- constructor, although it can be vacuous. -data Constructor = Constructor [CSFunDefArg] [CSStmt] - --- | A constructor that takes no arguments and does nothing. -emptyConstructor :: Constructor -emptyConstructor = Constructor [(Composite $ ArrayT $ Primitive StringT, "args")] [] - -constructorToConstructorDef :: Constructor -> String -> [CSStmt] -> CSStmt -constructorToConstructorDef (Constructor params body) name at_init = - ConstructorDef $ ClassConstructor name params $ body <> at_init - - -compileProg :: MonadFreshNames m => - Maybe String - -> Constructor - -> [CSStmt] - -> [CSStmt] - -> Operations op s - -> s - -> CompilerM op s () - -> [CSStmt] - -> [Space] - -> [Option] - -> Imp.Definitions op - -> m String -compileProg module_name constructor imports defines ops userstate boilerplate pre_timing _ options prog = do - src <- getNameSource - let prog' = runCompilerM ops src userstate compileProg' - let imports' = [ Using Nothing "System" - , Using Nothing "System.Diagnostics" - , Using Nothing "System.Collections" - , Using Nothing "System.Collections.Generic" - , Using Nothing "System.IO" - , Using Nothing "System.Linq" - , Using Nothing "System.Runtime.InteropServices" - , Using Nothing "static System.ValueTuple" - , Using Nothing "static System.Convert" - , Using Nothing "static System.Math" - , Using Nothing "System.Numerics" - , Using Nothing "Mono.Options" ] ++ imports - - return $ pretty (CSProg $ imports' ++ prog') - where Imp.Definitions consts (Imp.Functions funs) = prog - compileProg' = do - compileConstants consts - definitions <- mapM compileFunc funs - opencl_boilerplate <- collect boilerplate - compBeforeParses <- gets compBeforeParse - compInits <- gets compInit - staticDecls <- gets compStaticMemDecls - staticAllocs <- gets compStaticMemAllocs - extraMemberDecls <- gets compMemberDecls - let member_decls' = member_decls ++ extraMemberDecls ++ staticDecls - let at_inits' = at_inits ++ compBeforeParses ++ parse_options ++ compInits ++ staticAllocs - - - case module_name of - Just name -> do - entry_points <- mapM (compileEntryFun pre_timing) $ filter (Imp.functionEntry . snd) funs - let constructor' = constructorToConstructorDef constructor name at_inits' - return [ Namespace name [ClassDef $ PublicClass name $ member_decls' ++ - constructor' : defines' ++ opencl_boilerplate ++ - map PrivateFunDef definitions ++ - map PublicFunDef entry_points ]] - - - Nothing -> do - let name = "FutharkInternal" - let constructor' = constructorToConstructorDef constructor name at_inits' - (entry_point_defs, entry_point_names, entry_points) <- - unzip3 <$> mapM (callEntryFun pre_timing) - (filter (Imp.functionEntry . snd) funs) - - debug_ending <- gets compDebugItems - return [Namespace name (ClassDef - (PublicClass name $ - member_decls' ++ - constructor' : defines' ++ - opencl_boilerplate ++ - map PrivateFunDef (definitions ++ entry_point_defs) ++ - [PublicFunDef $ Def "InternalEntry" VoidT [] $ selectEntryPoint entry_point_names entry_points ++ debug_ending - ] - ) : - [ClassDef $ PublicClass "Program" - [StaticFunDef $ Def "Main" VoidT [(string_arrayT,"args")] main_entry]]) - ] - - - - string_arrayT = Composite $ ArrayT $ Primitive StringT - main_entry :: [CSStmt] - main_entry = [ Assign (Var "internalInstance") (simpleInitClass "FutharkInternal" [Var "args"]) - , Exp $ simpleCall "internalInstance.InternalEntry" [] - ] - - member_decls = - [ AssignTyped (CustomT "FileStream") (Var "RuntimeFile") Nothing - , AssignTyped (CustomT "StreamWriter") (Var "RuntimeFileWriter") Nothing - , AssignTyped (Primitive BoolT) (Var "DoWarmupRun") Nothing - , AssignTyped (Primitive $ CSInt Int32T) (Var "NumRuns") Nothing - , AssignTyped (Primitive StringT) (Var "EntryPoint") Nothing - ] - - at_inits = [ Reassign (Var "DoWarmupRun") (Bool False) - , Reassign (Var "NumRuns") (Integer 1) - , Reassign (Var "EntryPoint") (String "main") - , Exp $ simpleCall "ValueReader" [] - ] - - defines' = [ Escape csScalar - , Escape csMemory - , Escape csPanic - , Escape csExceptions - , Escape csReader] ++ defines - - parse_options = - generateOptionParser (standardOptions ++ options) - - selectEntryPoint entry_point_names entry_points = - [ Assign (Var "EntryPoints") $ - Collection "Dictionary" $ zipWith Pair (map String entry_point_names) entry_points, - If (simpleCall "!EntryPoints.ContainsKey" [Var "EntryPoint"]) - [ Exp $ simpleCall "Console.Error.WriteLine" - [simpleCall "string.Format" - [ String "No entry point '{0}'. Select another with --entry point. Options are:\n{1}" - , Var "EntryPoint" - , simpleCall "string.Join" - [ String "\n" - , Field (Var "EntryPoints") "Keys" ]]] - , Exp $ simpleCall "Environment.Exit" [Integer 1]] - [ Assign (Var "entryPointFun") $ - Index (Var "EntryPoints") (IdxExp $ Var "EntryPoint") - , Exp $ simpleCall "entryPointFun.Invoke" []] - ] - -compileConstants :: Imp.Constants op -> CompilerM op s () -compileConstants (Imp.Constants ps init_consts) = do - mapM_ addConstDecl ps - mapM_ staticMemAlloc =<< collect (compileCode init_consts) - where addConstDecl (Imp.ScalarParam p bt) = do - let t = compileType $ Imp.Scalar bt - addMemberDecl $ AssignTyped t (Var (compileName p)) Nothing - addConstDecl (Imp.MemParam p space) = do - let t = compileType $ Imp.Mem space - addMemberDecl $ AssignTyped t (Var (compileName p)) Nothing - case memInitExp space of - Nothing -> return () - Just e -> atInit $ Reassign (Var (compileName p)) e - -compileFunc :: (Name, Imp.Function op) -> CompilerM op s CSFunDef -compileFunc (fname, Imp.Function _ outputs inputs body _ _) = do - body' <- blockScope $ compileCode body - let inputs' = map compileTypedInput inputs - let outputs' = map compileOutput outputs - let outputDecls = map getDefaultDecl outputs - let (ret, retType) = unzip outputs' - let retType' = tupleOrSingleT retType - let ret' = [Return $ tupleOrSingle ret] - - case outputs of - [] -> return $ Def (futharkFun . nameToString $ fname) VoidT inputs' (outputDecls++body') - _ -> return $ Def (futharkFun . nameToString $ fname) retType' inputs' (outputDecls++body'++ret') - - -compileTypedInput :: Imp.Param -> (CSType, String) -compileTypedInput input = (typeFun input, nameFun input) - where nameFun = compileName . Imp.paramName - typeFun = compileType . paramType - -tupleOrSingleEntryT :: [CSType] -> CSType -tupleOrSingleEntryT [e] = e -tupleOrSingleEntryT es = Composite $ SystemTupleT es - -tupleOrSingleEntry :: [CSExp] -> CSExp -tupleOrSingleEntry [e] = e -tupleOrSingleEntry es = CreateSystemTuple es - -tupleOrSingleT :: [CSType] -> CSType -tupleOrSingleT [e] = e -tupleOrSingleT es = Composite $ TupleT es - -tupleOrSingle :: [CSExp] -> CSExp -tupleOrSingle [e] = e -tupleOrSingle es = Tuple es - -assignScalarPointer :: CSExp -> CSExp -> CSStmt -assignScalarPointer e ptr = - AssignTyped (PointerT VoidT) ptr (Just $ Addr e) - --- | A 'Call' where the function is a variable and every argument is a --- simple 'Arg'. -simpleCall :: String -> [CSExp] -> CSExp -simpleCall fname = Call (Var fname) . map simpleArg - -simpleArg :: CSExp -> CSArg -simpleArg = Arg Nothing - --- | A CallMethod -callMethod :: CSExp -> String -> [CSExp] -> CSExp -callMethod object method = CallMethod object (Var method) . map simpleArg - -simpleInitClass :: String -> [CSExp] -> CSExp -simpleInitClass fname =CreateObject (Var fname) . map simpleArg - -compileName :: VName -> String -compileName = zEncodeString . pretty - -compileVar :: VName -> CompilerM op s CSExp -compileVar v = - asks $ fromMaybe (Var $ compileName v) . M.lookup v . envVarExp - -compileType :: Imp.Type -> CSType -compileType (Imp.Scalar p) = compilePrimTypeToAST p -compileType (Imp.Mem space) = rawMemCSType space - -compilePrimTypeToAST :: PrimType -> CSType -compilePrimTypeToAST (IntType Int8) = Primitive $ CSInt Int8T -compilePrimTypeToAST (IntType Int16) = Primitive $ CSInt Int16T -compilePrimTypeToAST (IntType Int32) = Primitive $ CSInt Int32T -compilePrimTypeToAST (IntType Int64) = Primitive $ CSInt Int64T -compilePrimTypeToAST (FloatType Float32) = Primitive $ CSFloat FloatT -compilePrimTypeToAST (FloatType Float64) = Primitive $ CSFloat DoubleT -compilePrimTypeToAST Imp.Bool = Primitive BoolT -compilePrimTypeToAST Imp.Cert = Primitive BoolT - -compilePrimTypeToASText :: PrimType -> Imp.Signedness -> CSType -compilePrimTypeToASText (IntType Int8) Imp.TypeUnsigned = Primitive $ CSUInt UInt8T -compilePrimTypeToASText (IntType Int16) Imp.TypeUnsigned = Primitive $ CSUInt UInt16T -compilePrimTypeToASText (IntType Int32) Imp.TypeUnsigned = Primitive $ CSUInt UInt32T -compilePrimTypeToASText (IntType Int64) Imp.TypeUnsigned = Primitive $ CSUInt UInt64T -compilePrimTypeToASText (IntType Int8) _ = Primitive $ CSInt Int8T -compilePrimTypeToASText (IntType Int16) _ = Primitive $ CSInt Int16T -compilePrimTypeToASText (IntType Int32) _ = Primitive $ CSInt Int32T -compilePrimTypeToASText (IntType Int64) _ = Primitive $ CSInt Int64T -compilePrimTypeToASText (FloatType Float32) _ = Primitive $ CSFloat FloatT -compilePrimTypeToASText (FloatType Float64) _ = Primitive $ CSFloat DoubleT -compilePrimTypeToASText Imp.Bool _ = Primitive BoolT -compilePrimTypeToASText Imp.Cert _ = Primitive BoolT - -compileDim :: Imp.DimSize -> CSExp -compileDim (Imp.Constant v) = compilePrimValue v -compileDim (Imp.Var v) = Var $ compileName v - -unpackDim :: CSExp -> Imp.DimSize -> Int32 -> CompilerM op s () -unpackDim arr_name (Imp.Constant c) i = do - let shape_name = Field arr_name "Item2" -- array tuples are currently (data array * dimension array) currently - let constant_c = compilePrimValue c - let constant_i = Integer $ toInteger i - stm $ Assert (BinOp "==" constant_c (Index shape_name $ IdxExp constant_i)) [String "constant dimension wrong"] - -unpackDim arr_name (Imp.Var var) i = do - let shape_name = Field arr_name "Item2" - let src = Index shape_name $ IdxExp $ Integer $ toInteger i - dest <- compileVar var - isAssigned <- getVarAssigned var - if isAssigned - then - stm $ Reassign dest $ Cast (Primitive $ CSInt Int32T) src - else do - stm $ Assign dest $ Cast (Primitive $ CSInt Int32T) src - setVarAssigned var - -entryPointOutput :: Imp.ExternalValue -> CompilerM op s CSExp -entryPointOutput (Imp.OpaqueValue _ vs) = - CreateSystemTuple <$> mapM (entryPointOutput . Imp.TransparentValue) vs - -entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = - cast <$> compileVar name - where cast = compileTypecastExt bt ept - -entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do - mem' <- compileVar mem - unRefMem mem' (Imp.Space sid) - pack_output <- asks envEntryOutput - pack_output mem' sid bt ept dims - -entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do - src <- compileVar mem - let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept - return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ Right $ map compileDim dims] - -entryPointInput :: (Int, Imp.ExternalValue, CSExp) -> CompilerM op s () -entryPointInput (i, Imp.OpaqueValue _ vs, e) = - mapM_ entryPointInput $ zip3 (repeat i) (map Imp.TransparentValue vs) $ - map (\idx -> Field e $ "Item" ++ show (idx :: Int)) [1..] - -entryPointInput (_, Imp.TransparentValue (Imp.ScalarValue bt _ name), e) = do - vname' <- compileVar name - let cast = compileTypecast bt - stm $ Assign vname' (cast e) - -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do - unpack_input <- asks envEntryInput - unpack <- collect $ unpack_input mem sid bt ept dims e - stms unpack - -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem _ bt _ dims), e) = do - zipWithM_ (unpackDim e) dims [0..] - let arrayData = Field e "Item1" - dest <- compileVar mem - let unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt] - stm $ Assign dest unwrap_call - -extValueDescName :: Imp.ExternalValue -> String -extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v -extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc -extValueDescName (Imp.OpaqueValue desc (v:_)) = - extName $ zEncodeString desc ++ "_" ++ pretty (baseTag (valueDescVName v)) - -extName :: String -> String -extName = (++"_ext") - -sizeOf :: CSType -> CSExp -sizeOf t = simpleCall "sizeof" [(Var . pretty) t] - -privateFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt -privateFunDef s t args stmts = PrivateFunDef $ Def s t args stmts - -valueDescName :: Imp.ValueDesc -> String -valueDescName = compileName . valueDescVName - -valueDescVName :: Imp.ValueDesc -> VName -valueDescVName (Imp.ScalarValue _ _ vname) = vname -valueDescVName (Imp.ArrayValue vname _ _ _ _) = vname - -consoleErrorWrite :: String -> [CSExp] -> CSExp -consoleErrorWrite str exps = simpleCall "Console.Error.Write" $ String str:exps - -consoleErrorWriteLine :: String -> [CSExp] -> CSExp -consoleErrorWriteLine str exps = simpleCall "Console.Error.WriteLine" $ String str:exps - -readFun :: PrimType -> Imp.Signedness -> String -readFun (FloatType Float32) _ = "ReadF32" -readFun (FloatType Float64) _ = "ReadF64" -readFun (IntType Int8) Imp.TypeUnsigned = "ReadU8" -readFun (IntType Int16) Imp.TypeUnsigned = "ReadU16" -readFun (IntType Int32) Imp.TypeUnsigned = "ReadU32" -readFun (IntType Int64) Imp.TypeUnsigned = "ReadU64" -readFun (IntType Int8) Imp.TypeDirect = "ReadI8" -readFun (IntType Int16) Imp.TypeDirect = "ReadI16" -readFun (IntType Int32) Imp.TypeDirect = "ReadI32" -readFun (IntType Int64) Imp.TypeDirect = "ReadI64" -readFun Imp.Bool _ = "ReadBool" -readFun Cert _ = error "readFun: cert" - -readBinFun :: PrimType -> Imp.Signedness -> String -readBinFun (FloatType Float32) _bin_ = "ReadBinF32" -readBinFun (FloatType Float64) _bin_ = "ReadBinF64" -readBinFun (IntType Int8) Imp.TypeUnsigned = "ReadBinU8" -readBinFun (IntType Int16) Imp.TypeUnsigned = "ReadBinU16" -readBinFun (IntType Int32) Imp.TypeUnsigned = "ReadBinU32" -readBinFun (IntType Int64) Imp.TypeUnsigned = "ReadBinU64" -readBinFun (IntType Int8) Imp.TypeDirect = "ReadBinI8" -readBinFun (IntType Int16) Imp.TypeDirect = "ReadBinI16" -readBinFun (IntType Int32) Imp.TypeDirect = "ReadBinI32" -readBinFun (IntType Int64) Imp.TypeDirect = "ReadBinI64" -readBinFun Imp.Bool _ = "ReadBinBool" -readBinFun Cert _ = error "readFun: cert" - --- The value returned will be used when reading binary arrays, to indicate what --- the expected type is --- Key into the FUTHARK_PRIMTYPES dict. -readTypeEnum :: PrimType -> Imp.Signedness -> String -readTypeEnum (IntType Int8) Imp.TypeUnsigned = "u8" -readTypeEnum (IntType Int16) Imp.TypeUnsigned = "u16" -readTypeEnum (IntType Int32) Imp.TypeUnsigned = "u32" -readTypeEnum (IntType Int64) Imp.TypeUnsigned = "u64" -readTypeEnum (IntType Int8) Imp.TypeDirect = "i8" -readTypeEnum (IntType Int16) Imp.TypeDirect = "i16" -readTypeEnum (IntType Int32) Imp.TypeDirect = "i32" -readTypeEnum (IntType Int64) Imp.TypeDirect = "i64" -readTypeEnum (FloatType Float32) _ = "f32" -readTypeEnum (FloatType Float64) _ = "f64" -readTypeEnum Imp.Bool _ = "bool" -readTypeEnum Cert _ = error "readTypeEnum: cert" - -readInput :: Imp.ExternalValue -> CSStmt -readInput (Imp.OpaqueValue desc _) = - Throw $ simpleInitClass "Exception" [String $ "Cannot read argument of type " ++ desc ++ "."] - -readInput decl@(Imp.TransparentValue (Imp.ScalarValue bt ept _)) = - let read_func = Var $ readFun bt ept - read_bin_func = Var $ readBinFun bt ept - type_enum = String $ readTypeEnum bt ept - bt' = compilePrimTypeExt bt ept - readScalar = initializeGenericFunction "ReadScalar" bt' - in Assign (Var $ extValueDescName decl) $ simpleCall readScalar [type_enum, read_func, read_bin_func] - --- TODO: If the type identifier of 'Float32' is changed, currently the error --- messages for reading binary input will not use this new name. This is also a --- problem for the C runtime system. -readInput decl@(Imp.TransparentValue (Imp.ArrayValue _ _ bt ept dims)) = - let rank' = Var $ show $ length dims - type_enum = String $ readTypeEnum bt ept - bt' = compilePrimTypeExt bt ept - read_func = Var $ readFun bt ept - readArray = initializeGenericFunction "ReadArray" bt' - in Assign (Var $ extValueDescName decl) $ simpleCall readArray [rank', type_enum, read_func] - -initializeGenericFunction :: String -> String -> String -initializeGenericFunction fun tp = fun ++ "<" ++ tp ++ ">" - - -printPrimStm :: CSExp -> CSStmt -printPrimStm val = Exp $ simpleCall "WriteValue" [val] - -formatString :: String -> [CSExp] -> CSExp -formatString fmt contents = - simpleCall "String.Format" $ String fmt : contents - -printStm :: Imp.ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt -printStm Imp.ScalarValue{} _ e = - return $ printPrimStm e -printStm (Imp.ArrayValue _ _ _ _ []) ind e = do - let e' = Index e (IdxExp (PostUnOp "++" ind)) - return $ printPrimStm e' - -printStm (Imp.ArrayValue mem space bt ept (outer:shape)) ind e = do - ptr <- newVName "shapePtr" - first <- newVName "printFirst" - let dims = map compileDim $ outer:shape - size = callMethod (CreateArray (Primitive $ CSInt Int32T) $ Right dims) - "Aggregate" [ Integer 1 - , Lambda (Tuple [Var "acc", Var "val"]) - [Exp $ BinOp "*" (Var "acc") (Var "val")] - ] - emptystr = "empty(" ++ ppArrayType bt [0..length dims-1] ++ ")" - - printelem <- printStm (Imp.ArrayValue mem space bt ept shape) ind e - return $ - If (BinOp "==" size (Integer 0)) - [Exp $ simpleCall "Console.Write" [formatString emptystr dims]] - [ Assign (Var $ pretty first) $ Var "true" - , puts "[" - , For (pretty ptr) (compileDim outer) - [ If (simpleCall "!" [Var $ pretty first]) [puts ", "] [] - , printelem - , Reassign (Var $ pretty first) $ Var "false" - ] - , puts "]" - ] - - where ppArrayType t [] = prettyPrimType ept t - ppArrayType t (i:is) = "[{" ++ show i ++ "}]" ++ ppArrayType t is - - prettyPrimType Imp.TypeUnsigned (IntType Int8) = "u8" - prettyPrimType Imp.TypeUnsigned (IntType Int16) = "u16" - prettyPrimType Imp.TypeUnsigned (IntType Int32) = "u32" - prettyPrimType Imp.TypeUnsigned (IntType Int64) = "u64" - prettyPrimType _ t = pretty t - - puts s = Exp $ simpleCall "Console.Write" [String s] - -printValue :: [(Imp.ExternalValue, CSExp)] -> CompilerM op s [CSStmt] -printValue = fmap concat . mapM (uncurry printValue') - -- We copy non-host arrays to the host before printing. This is - -- done in a hacky way - we assume the value has a .get()-method - -- that returns an equivalent Numpy array. This works for CSOpenCL, - -- but we will probably need yet another plugin mechanism here in - -- the future. - where printValue' (Imp.OpaqueValue desc _) _ = - return [Exp $ simpleCall "Console.Write" - [String $ "#"]] - printValue' (Imp.TransparentValue r@Imp.ScalarValue{}) e = do - p <- printStm r (Integer 0) e - return [p, Exp $ simpleCall "Console.Write" [String "\n"]] - printValue' (Imp.TransparentValue r@Imp.ArrayValue{}) e = do - tuple <- newVName "resultArr" - i <- newVName "arrInd" - let i' = Var $ compileName i - p <- printStm r i' (Var $ compileName tuple) - let e' = Var $ pretty e - return [ Assign (Var $ compileName tuple) (Field e' "Item1") - , Assign i' (Integer 0) - , p - , Exp $ simpleCall "Console.Write" [String "\n"]] - -prepareEntry :: (Name, Imp.Function op) -> CompilerM op s - (String, [(CSType, String)], CSType, [CSStmt], [CSStmt], [CSStmt], [CSStmt], - [(Imp.ExternalValue, CSExp)], [CSStmt]) -prepareEntry (fname, Imp.Function _ outputs inputs _ results args) = do - let (output_types, output_paramNames) = unzip $ map compileTypedInput outputs - funTuple = tupleOrSingle $ fmap Var output_paramNames - - - (_, sizeDecls) <- collect' $ forM args declsfunction - - (argexps_mem_copies, prepare_run) <- collect' $ forM inputs $ \case - Imp.MemParam name space -> do - -- A program might write to its input parameters, so create a new memory - -- block and copy the source there. This way the program can be run more - -- than once. - name' <- newVName $ baseString name <> "_copy" - copy <- asks envCopy - allocate <- asks envAllocate - - let size = Var (compileName name ++ "_nbytes") - dest = Var $ compileName name' - src = Var $ compileName name - offset = Integer 0 - case space of - Space sid -> - allocate dest size sid - _ -> - stm $ Reassign dest (simpleCall "allocateMem" [size]) -- FIXME - copy dest offset space src offset space size (IntType Int64) -- FIXME - return $ Just dest - _ -> return Nothing - - prepareIn <- collect $ mapM_ entryPointInput $ zip3 [0..] args $ - map (Var . extValueDescName) args - (res, prepareOut) <- collect' $ mapM entryPointOutput results - - let mem_copies = mapMaybe liftMaybe $ zip argexps_mem_copies inputs - mem_copy_inits = map initCopy mem_copies - - argexps_lib = map (Var . compileName . Imp.paramName) inputs - argexps_bin = zipWith fromMaybe argexps_lib argexps_mem_copies - fname' = futharkFun (nameToString fname) - arg_types = map (fst . compileTypedInput) inputs - inputs' = zip arg_types (map extValueDescName args) - output_type = tupleOrSingleEntryT output_types - call_lib = [Reassign funTuple $ simpleCall fname' argexps_lib] - call_bin = [Reassign funTuple $ simpleCall fname' argexps_bin] - prepareIn' = prepareIn ++ mem_copy_inits ++ sizeDecls - - return (nameToString fname, inputs', output_type, - prepareIn', call_lib, call_bin, prepareOut, - zip results res, prepare_run) - - where liftMaybe (Just a, b) = Just (a,b) - liftMaybe _ = Nothing - - initCopy (varName, Imp.MemParam _ space) = declMem' varName space - initCopy _ = Pass - - valueDescFun (Imp.ArrayValue mem Imp.DefaultSpace _ _ _) = - stm $ Assign (Var $ compileName mem ++ "_nbytes") (Var $ compileName mem ++ ".Length") - valueDescFun (Imp.ArrayValue mem (Imp.Space _) bt _ dims) = - stm $ Assign (Var $ compileName mem ++ "_nbytes") $ foldr (BinOp "*" . compileDim) (sizeOf $ compilePrimTypeToAST bt) dims - valueDescFun _ = stm Pass - - declsfunction (Imp.TransparentValue v) = valueDescFun v - declsfunction (Imp.OpaqueValue _ vs) = mapM_ valueDescFun vs - -copyMemoryDefaultSpace :: CSExp -> CSExp -> CSExp -> CSExp -> CSExp -> - CompilerM op s () -copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes = - stm $ Exp $ simpleCall "Buffer.BlockCopy" [ srcmem, srcidx - , destmem, destidx - , nbytes] - -compileEntryFun :: [CSStmt] -> (Name, Imp.Function op) - -> CompilerM op s CSFunDef -compileEntryFun pre_timing entry@(_,Imp.Function _ outputs _ _ results args) = do - let params = map (getType &&& extValueDescName) args - let outputType = tupleOrSingleEntryT $ map getType results - - (fname', _, _, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry - let ret = Return $ tupleOrSingleEntry $ map snd res - let outputDecls = map getDefaultDecl outputs - do_run = body_lib ++ pre_timing - (do_run_with_timing, close_runtime_file) <- addTiming do_run - - let do_warmup_run = If (Var "DoWarmupRun") do_run [] - do_num_runs = For "i" (Var "NumRuns") do_run_with_timing - - return $ Def fname' outputType params $ - prepareIn ++ outputDecls ++ [do_warmup_run, do_num_runs, close_runtime_file] ++ prepareOut ++ [ret] - - where getType :: Imp.ExternalValue -> CSType - getType (Imp.OpaqueValue _ valueDescs) = - let valueDescs' = map getType' valueDescs - in Composite $ SystemTupleT valueDescs' - getType (Imp.TransparentValue valueDesc) = - getType' valueDesc - - getType' :: Imp.ValueDesc -> CSType - getType' (Imp.ScalarValue primtype signedness _) = - compilePrimTypeToASText primtype signedness - getType' (Imp.ArrayValue _ _ primtype signedness _) = - let t = compilePrimTypeToASText primtype signedness - in Composite $ SystemTupleT [Composite $ ArrayT t, Composite $ ArrayT $ Primitive $ CSInt Int64T] - - -callEntryFun :: [CSStmt] -> (Name, Imp.Function op) - -> CompilerM op s (CSFunDef, String, CSExp) -callEntryFun pre_timing entry@(fname, Imp.Function _ outputs _ _ _ decl_args) = - if any isOpaque decl_args then - return (Def fname' VoidT [] [exitException], nameToString fname, Var fname') - else do - (_, _, _, prepare_in, _, body_bin, prepare_out, res, prepare_run) <- prepareEntry entry - let str_input = map readInput decl_args - end_of_input = [Exp $ simpleCall "EndOfInput" [String $ pretty fname]] - - let outputDecls = map getDefaultDecl outputs - exitcall = [ - Exp $ simpleCall "Console.Error.WriteLine" [formatString "Assertion.{0} failed" [Var "e"]] - , Exp $ simpleCall "Environment.Exit" [Integer 1] - ] - except' = Catch (Var "Exception") exitcall - do_run = body_bin ++ pre_timing - (do_run_with_timing, close_runtime_file) <- addTiming do_run - - -- We ignore overflow errors and the like for executable entry - -- points. These are (somewhat) well-defined in Futhark. - - let maybe_free = - [If (BinOp "<" (Var "i") (BinOp "-" (Var "NumRuns") (Integer 1))) - prepare_out []] - - do_warmup_run = - If (Var "DoWarmupRun") (prepare_run ++ do_run ++ prepare_out) [] - - do_num_runs = - For "i" (Var "NumRuns") (prepare_run ++ do_run_with_timing ++ maybe_free) - - str_output <- printValue res - - return (Def fname' VoidT [] $ - str_input ++ end_of_input ++ prepare_in ++ outputDecls ++ - [Try [do_warmup_run, do_num_runs] [except']] ++ - [close_runtime_file] ++ - str_output, - - nameToString fname, - - Var fname') - - where fname' = "entry_" ++ nameToString fname - isOpaque Imp.TransparentValue{} = False - isOpaque _ = True - - exitException = Throw $ simpleInitClass "Exception" [String $ "The function " ++ nameToString fname ++ " is not available as an entry function."] - -addTiming :: [CSStmt] -> CompilerM s op ([CSStmt], CSStmt) -addTiming statements = do - syncFun <- asks envSyncFun - - return ([ Assign (Var "StopWatch") $ simpleInitClass "Stopwatch" [] - , syncFun - , Exp $ simpleCall "StopWatch.Start" [] ] ++ - statements ++ - [ syncFun - , Exp $ simpleCall "StopWatch.Stop" [] - , Assign (Var "timeElapsed") $ asMicroseconds (Var "StopWatch") - , If (not_null (Var "RuntimeFile")) [print_runtime] [] - ] - , If (not_null (Var "RuntimeFile")) [ - Exp $ simpleCall "RuntimeFileWriter.Close" [] , - Exp $ simpleCall "RuntimeFile.Close" [] - ] [] - ) - - where print_runtime = Exp $ simpleCall "RuntimeFileWriter.WriteLine" [ callMethod (Var "timeElapsed") "ToString" [] ] - not_null var = BinOp "!=" var Null - asMicroseconds watch = - BinOp "/" (Field watch "ElapsedTicks") - (BinOp "/" (Field (Var "TimeSpan") "TicksPerMillisecond") (Integer 1000)) - -compileUnOp :: Imp.UnOp -> String -compileUnOp op = - case op of - Not -> "!" - Complement{} -> "~" - Abs{} -> "Math.Abs" -- actually write these helpers - FAbs{} -> "Math.Abs" - SSignum{} -> "ssignum" - USignum{} -> "usignum" - -compileBinOpLike :: Monad m => - Imp.Exp -> Imp.Exp - -> CompilerM op s (CSExp, CSExp, String -> m CSExp) -compileBinOpLike x y = do - x' <- compileExp x - y' <- compileExp y - let simple s = return $ BinOp s x' y' - return (x', y', simple) - --- | The ctypes type corresponding to a 'PrimType'. -compilePrimType :: PrimType -> String -compilePrimType t = - case t of - IntType Int8 -> "sbyte" - IntType Int16 -> "short" - IntType Int32 -> "int" - IntType Int64 -> "long" - FloatType Float32 -> "float" - FloatType Float64 -> "double" - Imp.Bool -> "bool" - Cert -> "bool" - --- | The ctypes type corresponding to a 'PrimType', taking sign into account. -compilePrimTypeExt :: PrimType -> Imp.Signedness -> String -compilePrimTypeExt t ept = - case (t, ept) of - (IntType Int8, Imp.TypeUnsigned) -> "byte" - (IntType Int16, Imp.TypeUnsigned) -> "ushort" - (IntType Int32, Imp.TypeUnsigned) -> "uint" - (IntType Int64, Imp.TypeUnsigned) -> "ulong" - (IntType Int8, _) -> "sbyte" - (IntType Int16, _) -> "short" - (IntType Int32, _) -> "int" - (IntType Int64, _) -> "long" - (FloatType Float32, _) -> "float" - (FloatType Float64, _) -> "double" - (Imp.Bool, _) -> "bool" - (Cert, _) -> "byte" - --- | Select function to retrieve bytes from byte array as specific data type --- | The ctypes type corresponding to a 'PrimType'. -compileTypecastExt :: PrimType -> Imp.Signedness -> (CSExp -> CSExp) -compileTypecastExt t ept = - let t' = case (t, ept) of - (IntType Int8 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt8T - (IntType Int16 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt16T - (IntType Int32 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt32T - (IntType Int64 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt64T - (IntType Int8 , _)-> Primitive $ CSInt Int8T - (IntType Int16 , _)-> Primitive $ CSInt Int16T - (IntType Int32 , _)-> Primitive $ CSInt Int32T - (IntType Int64 , _)-> Primitive $ CSInt Int64T - (FloatType Float32, _)-> Primitive $ CSFloat FloatT - (FloatType Float64, _)-> Primitive $ CSFloat DoubleT - (Imp.Bool , _)-> Primitive BoolT - (Cert, _)-> Primitive $ CSInt Int8T - in Cast t' - --- | The ctypes type corresponding to a 'PrimType'. -compileTypecast :: PrimType -> (CSExp -> CSExp) -compileTypecast t = - let t' = case t of - IntType Int8 -> Primitive $ CSInt Int8T - IntType Int16 -> Primitive $ CSInt Int16T - IntType Int32 -> Primitive $ CSInt Int32T - IntType Int64 -> Primitive $ CSInt Int64T - FloatType Float32 -> Primitive $ CSFloat FloatT - FloatType Float64 -> Primitive $ CSFloat DoubleT - Imp.Bool -> Primitive BoolT - Cert -> Primitive $ CSInt Int8T - in Cast t' - --- | The ctypes type corresponding to a 'PrimType'. -compilePrimValue :: Imp.PrimValue -> CSExp -compilePrimValue (IntValue (Int8Value v)) = - Cast (Primitive $ CSInt Int8T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int16Value v)) = - Cast (Primitive $ CSInt Int16T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int32Value v)) = - Cast (Primitive $ CSInt Int32T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int64Value v)) = - Cast (Primitive $ CSInt Int64T) $ Integer $ toInteger v -compilePrimValue (FloatValue (Float32Value v)) - | isInfinite v = - if v > 0 then Var "Single.PositiveInfinity" else Var "Single.NegativeInfinity" - | isNaN v = - Var "Single.NaN" - | otherwise = Cast (Primitive $ CSFloat FloatT) (Float $ fromRational $ toRational v) -compilePrimValue (FloatValue (Float64Value v)) - | isInfinite v = - if v > 0 then Var "Double.PositiveInfinity" else Var "Double.NegativeInfinity" - | isNaN v = - Var "Double.NaN" - | otherwise = Cast (Primitive $ CSFloat DoubleT) (Float $ fromRational $ toRational v) -compilePrimValue (BoolValue v) = Bool v -compilePrimValue Checked = Bool True - -compileExp :: Imp.Exp -> CompilerM op s CSExp - -compileExp (Imp.ValueExp v) = return $ compilePrimValue v - -compileExp (Imp.LeafExp (Imp.ScalarVar vname) _) = - compileVar vname - -compileExp (Imp.LeafExp (Imp.SizeOf t) _) = - return $ (compileTypecast $ IntType Int32) (Integer $ primByteSize t) - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) = - join $ asks envReadScalar - <*> compileVar src <*> compileExp iexp - <*> pure restype <*> pure space - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) _ _) _) = do - src' <- compileVar src - iexp' <- compileExp iexp - return $ Cast (Primitive $ CSInt Int8T) (Index src' (IdxExp iexp')) - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt _ _) _) = do - iexp' <- compileExp iexp - let bt' = compilePrimType bt - iexp'' = BinOp "*" iexp' (sizeOf (compilePrimTypeToAST bt)) - src' <- compileVar src - return $ simpleCall ("indexArray_" ++ bt') [src', iexp''] - -compileExp (Imp.BinOpExp op x y) = do - (x', y', simple) <- compileBinOpLike x y - case op of - FAdd{} -> simple "+" - FSub{} -> simple "-" - FMul{} -> simple "*" - FDiv{} -> simple "/" - FMod{} -> simple "%" - LogAnd{} -> simple "&&" - LogOr{} -> simple "||" - _ -> return $ simpleCall (pretty op) [x', y'] - -compileExp (Imp.ConvOpExp conv x) = do - x' <- compileExp x - return $ simpleCall (pretty conv) [x'] - -compileExp (Imp.CmpOpExp cmp x y) = do - (x', y', simple) <- compileBinOpLike x y - case cmp of - CmpEq{} -> simple "==" - FCmpLt{} -> simple "<" - FCmpLe{} -> simple "<=" - _ -> return $ simpleCall (pretty cmp) [x', y'] - -compileExp (Imp.UnOpExp op exp1) = - PreUnOp (compileUnOp op) <$> compileExp exp1 - -compileExp (Imp.FunExp h args _) = - simpleCall (futharkFun (pretty h)) <$> mapM compileExp args - -compileCode :: Imp.Code op -> CompilerM op s () - -compileCode Imp.DebugPrint{} = - return () - -compileCode (Imp.Op op) = - join $ asks envOpCompiler <*> pure op - -compileCode (Imp.If cond tb fb) = do - cond' <- compileExp cond - tb' <- blockScope $ compileCode tb - fb' <- blockScope $ compileCode fb - stm $ If cond' tb' fb' - -compileCode (c1 Imp.:>>: c2) = do - compileCode c1 - compileCode c2 - -compileCode (Imp.While cond body) = do - cond' <- compileExp cond - body' <- blockScope $ compileCode body - stm $ While cond' body' - -compileCode (Imp.For i it bound body) = do - bound' <- compileExp bound - let i' = compileName i - body' <- blockScope $ compileCode body - counter <- pretty <$> newVName "counter" - one <- pretty <$> newVName "one" - stm $ Assign (Var i') $ compileTypecast (IntType it) (Integer 0) - stm $ Assign (Var one) $ compileTypecast (IntType it) (Integer 1) - stm $ For counter bound' $ body' ++ - [AssignOp "+" (Var i') (Var one)] - - -compileCode (Imp.SetScalar vname exp1) = - stm =<< Reassign <$> compileVar vname <*> compileExp exp1 - -compileCode (Imp.DeclareMem v space) = declMem v space - -compileCode (Imp.DeclareScalar v _ Cert) = - stm =<< Assign <$> compileVar v <*> pure (Bool True) -compileCode (Imp.DeclareScalar v _ t) = - stm =<< AssignTyped t' <$> compileVar v <*> pure Nothing - where t' = compilePrimTypeToAST t - -compileCode (Imp.DeclareArray name (Space space) t vs) = - join $ asks envStaticArray <*> - pure name <*> pure space <*> pure t <*> pure vs - -compileCode (Imp.DeclareArray name _ t vs) = do - name' <- compileVar name - stms [Assign (Var $ "init_"++compileName name) $ - simpleCall "unwrapArray" - [ - case vs of Imp.ArrayValues vs' -> - CreateArray (compilePrimTypeToAST t) $ Right $ map compilePrimValue vs' - Imp.ArrayZeros n -> - CreateArray (compilePrimTypeToAST t) $ Left n - , simpleCall "sizeof" [Var $ compilePrimType t] - ] - , Assign name' $ Var ("init_"++compileName name) - ] - -compileCode (Imp.Comment s code) = do - code' <- blockScope $ compileCode code - stm $ Comment s code' - -compileCode (Imp.Assert e (Imp.ErrorMsg parts) (loc,locs)) = do - e' <- compileExp e - let onPart (i, Imp.ErrorString s) = return (printFormatArg i, String s) - onPart (i, Imp.ErrorInt32 x) = (printFormatArg i,) <$> compileExp x - (formatstrs, formatargs) <- unzip <$> mapM onPart (zip ([0..] :: [Integer]) parts) - stm $ Assert e' $ String ("Error: " <> concat formatstrs <> - "\n\nBacktrace:\n" ++ "{" ++ show (length formatargs) ++ "}") : - (formatargs ++ [String stacktrace]) - where stacktrace = prettyStacktrace 0 $ map locStr $ loc:locs - printFormatArg i = "{" ++ show i ++ "}" - -compileCode (Imp.Call dests fname args) = do - args' <- mapM compileArg args - dests' <- tupleOrSingle <$> mapM compileVar dests - let fname' = futharkFun (pretty fname) - call' = simpleCall fname' args' - -- If the function returns nothing (is called only for side - -- effects), take care not to assign to an empty tuple. - stm $ if null dests - then Exp call' - else Reassign dests' call' - where compileArg (Imp.MemArg m) = compileVar m - compileArg (Imp.ExpArg e) = compileExp e - -compileCode (Imp.SetMem dest src DefaultSpace) = - stm =<< Reassign <$> compileVar dest <*> compileVar src - -compileCode (Imp.SetMem dest src _) = do - src' <- compileVar src - dest' <- compileVar dest - stm $ Exp $ simpleCall "MemblockSetDevice" [Ref $ Var "Ctx", Ref dest', Ref src', String $ pretty src'] - -compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) = - join $ asks envAllocate - <*> compileVar name - <*> compileExp e - <*> pure space - -compileCode (Imp.Allocate name (Imp.Count e) _) = do - e' <- compileExp e - let allocate' = simpleCall "allocateMem" [e'] - stm =<< Reassign <$> compileVar name <*> pure allocate' - -compileCode (Imp.Free name space) = do - name' <- compileVar name - unRefMem name' space - tell $ mempty { accFreedMem = [name] } - -compileCode (Imp.Copy dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do - destoffset' <- compileExp destoffset - srcoffset' <- compileExp srcoffset - dest' <- compileVar dest - src' <- compileVar src - size' <- compileExp size - stm $ Exp $ simpleCall "Buffer.BlockCopy" - [src', srcoffset', dest', destoffset', - Cast (Primitive $ CSInt Int32T) size'] - -compileCode (Imp.Copy dest (Imp.Count destoffset) destspace src (Imp.Count srcoffset) srcspace (Imp.Count size)) = do - copy <- asks envCopy - join $ copy - <$> compileVar dest <*> compileExp destoffset <*> pure destspace - <*> compileVar src <*> compileExp srcoffset <*> pure srcspace - <*> compileExp size <*> pure (IntType Int64) -- FIXME - -compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) = - join $ asks envWriteScalar - <*> compileVar dest - <*> compileExp idx - <*> pure elemtype - <*> pure space - <*> compileExp elemexp - -compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do - idx' <- compileExp idx - elemexp' <- compileExp elemexp - dest' <- compileVar dest - let elemtype' = compileTypecast elemtype - ctype = elemtype' elemexp' - idx'' = BinOp "*" idx' (sizeOf (compilePrimTypeToAST elemtype)) - - stm $ Exp $ simpleCall "writeScalarArray" [dest', idx'', ctype] - -compileCode Imp.Skip = return () - -blockScope :: CompilerM op s () -> CompilerM op s [CSStmt] -blockScope = fmap snd . blockScope' - -blockScope' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) -blockScope' m = do - old_allocs <- gets compDeclaredMem - (x, items) <- pass $ do - (x, w) <- listen m - let items = accItems w - return ((x, items), const mempty) - new_allocs <- gets $ filter (`notElem` old_allocs) . compDeclaredMem - modify $ \s -> s { compDeclaredMem = old_allocs } - releases <- collect $ mapM_ (uncurry unRefMem) new_allocs - return (x, items <> releases) - -unRefMem :: CSExp -> Space -> CompilerM op s () -unRefMem mem (Space "device") = - stm $ Exp $ - simpleCall "MemblockUnrefDevice" [ Ref $ Var "Ctx" - , Ref mem - , String $ pretty mem] -unRefMem _ DefaultSpace = stm Pass -unRefMem _ (Space "local") = stm Pass -unRefMem _ _ = error "The default compiler cannot compile unRefMem for other spaces" - - --- | Public names must have a consistent prefix. -publicName :: String -> String -publicName s = "Futhark" ++ s - -declMem :: VName -> Space -> CompilerM op s () -declMem name space = do - name' <- compileVar name - modify $ \s -> s { compDeclaredMem = (name', space) : compDeclaredMem s} - stm $ declMem' name' space - -memInitExp :: Space -> Maybe CSExp -memInitExp (Space _) = - Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"] -memInitExp _ = - Nothing - -declMem' :: CSExp -> Space -> CSStmt -declMem' name space@(Space _) = - AssignTyped (CustomT "OpenCLMemblock") name $ memInitExp space -declMem' name _ = - AssignTyped (Composite $ ArrayT $ Primitive ByteT) name Nothing - -rawMemCSType :: Space -> CSType -rawMemCSType (Space _) = CustomT "OpenCLMemblock" -rawMemCSType _ = Composite $ ArrayT $ Primitive ByteT - -toIntPtr :: CSExp -> CSExp -toIntPtr e = simpleInitClass "IntPtr" [e] diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp/AST.hs b/src/Futhark/CodeGen/Backends/GenericCSharp/AST.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/GenericCSharp/AST.hs +++ /dev/null @@ -1,413 +0,0 @@ -{-# LANGUAGE PostfixOperators #-} - - -module Futhark.CodeGen.Backends.GenericCSharp.AST - ( CSExp(..) - , CSType(..) - , CSComp(..) - , CSPrim(..) - , CSInt(..) - , CSUInt(..) - , CSFloat(..) - , CSIdx (..) - , ArgMemType(..) - , CSArg (..) - , CSStmt(..) - , module Language.Futhark.Core - , CSProg(..) - , CSExcept(..) - , CSFunDef(..) - , CSFunDefArg - , CSClassDef(..) - , CSConstructorDef(..) - ) - where - -import Language.Futhark.Core -import Data.List(intersperse) -import Futhark.Util.Pretty - -data MemT = Pointer - deriving (Eq, Show) - -data ArgMemType = ArgOut - | ArgRef - deriving (Eq, Show) - -instance Pretty ArgMemType where - ppr ArgOut = text "out" - ppr ArgRef = text "ref" - -instance Pretty CSComp where - ppr (ArrayT t) = ppr t <> text "[]" - ppr (TupleT ts) = parens(commasep $ map ppr ts) - ppr (SystemTupleT ts) = text "Tuple" <> angles(commasep $ map ppr ts) - -data CSInt = Int8T - | Int16T - | Int32T - | Int64T - deriving (Eq, Show) - -data CSUInt = UInt8T - | UInt16T - | UInt32T - | UInt64T - deriving (Eq, Show) - -data CSFloat = FloatT - | DoubleT - deriving (Eq, Show) - -data CSType = Composite CSComp - | PointerT CSType - | Primitive CSPrim - | CustomT String - | StaticT CSType - | OutT CSType - | RefT CSType - | VoidT - deriving (Eq, Show) - -data CSComp = ArrayT CSType - | TupleT [CSType] - | SystemTupleT [CSType] - deriving (Eq, Show) - -data CSPrim = CSInt CSInt - | CSUInt CSUInt - | CSFloat CSFloat - | BoolT - | ByteT - | StringT - | IntPtrT - deriving (Eq, Show) - -instance Pretty CSType where - ppr (Composite t) = ppr t - ppr (PointerT t) = ppr t <> text "*" - ppr (Primitive t) = ppr t - ppr (CustomT t) = text t - ppr (StaticT t) = text "static" <+> ppr t - ppr (OutT t) = text "out" <+> ppr t - ppr (RefT t) = text "ref" <+> ppr t - ppr VoidT = text "void" - -instance Pretty CSPrim where - ppr BoolT = text "bool" - ppr ByteT = text "byte" - ppr (CSInt t) = ppr t - ppr (CSUInt t) = ppr t - ppr (CSFloat t) = ppr t - ppr StringT = text "string" - ppr IntPtrT = text "IntPtr" - -instance Pretty CSInt where - ppr Int8T = text "sbyte" - ppr Int16T = text "short" - ppr Int32T = text "int" - ppr Int64T = text "long" - -instance Pretty CSUInt where - ppr UInt8T = text "byte" - ppr UInt16T = text "ushort" - ppr UInt32T = text "uint" - ppr UInt64T = text "ulong" - -instance Pretty CSFloat where - ppr FloatT = text "float" - ppr DoubleT = text "double" - -data UnOp = Not -- ^ Boolean negation. - | Complement -- ^ Bitwise complement. - | Negate -- ^ Numerical negation. - | Abs -- ^ Absolute/numerical value. - deriving (Eq, Show) - -data CSExp = Integer Integer - | Bool Bool - | Float Double - | String String - | RawStringLiteral String - | Var String - | Addr CSExp - | Ref CSExp - | Out CSExp - | Deref String - | BinOp String CSExp CSExp - | PreUnOp String CSExp - | PostUnOp String CSExp - | Ternary CSExp CSExp CSExp - | Cond CSExp CSExp CSExp - | Index CSExp CSIdx - | Pair CSExp CSExp - | Call CSExp [CSArg] - | CallMethod CSExp CSExp [CSArg] - | CreateObject CSExp [CSArg] - | CreateArray CSType (Either Int [CSExp]) - | CreateSystemTuple [CSExp] - | AllocArray CSType CSExp - | Cast CSType CSExp - | Tuple [CSExp] - | Array [CSExp] - | Field CSExp String - | Lambda CSExp [CSStmt] - | Collection String [CSExp] - | This CSExp - | Null - deriving (Eq, Show) - -instance Pretty CSExp where - ppr (Integer x) = ppr x - ppr (Float x) - | isInfinite x = text $ if x > 0 then "Double.PositiveInfinity" else "Double.NegativeInfinity" - | otherwise = ppr x - ppr (Bool True) = text "true" - ppr (Bool False) = text "false" - ppr (String x) = text $ show x - ppr (RawStringLiteral s) = text "@\"" <> text s <> text "\"" - ppr (Var n) = text $ map (\x -> if x == '\'' then 'm' else x) n - ppr (Addr e) = text "&" <> ppr e - ppr (Ref e) = text "ref" <+> ppr e - ppr (Out e) = text "out" <+> ppr e - ppr (Deref n) = text "*" <> text (map (\x -> if x == '\'' then 'm' else x) n) - ppr (BinOp s e1 e2) = parens(ppr e1 <+> text s <+> ppr e2) - ppr (PreUnOp s e) = text s <> parens (ppr e) - ppr (PostUnOp s e) = parens (ppr e) <> text s - ppr (Ternary b e1 e2) = ppr b <+> text "?" <+> ppr e1 <+> colon <+> ppr e2 - ppr (Cond e1 e2 e3) = text "if" <+> parens(ppr e1) <> braces(ppr e2) <+> text "else" <> braces(ppr e3) - ppr (Cast bt src) = parens(ppr bt) <+> ppr src - ppr (Index src (IdxExp idx)) = ppr src <> brackets(ppr idx) - ppr (Index src (IdxRange from to)) = text "MySlice" <> parens(commasep $ map ppr [src, from, to]) - ppr (Pair e1 e2) = braces(ppr e1 <> comma <> ppr e2) - ppr (Call fun args) = ppr fun <> parens(commasep $ map ppr args) - ppr (CallMethod obj method args) = ppr obj <> dot <> ppr method <> parens(commasep $ map ppr args) - ppr (CreateObject className args) = text "new" <+> ppr className <> parens(commasep $ map ppr args) - ppr (CreateArray t (Left n)) = text "new" <+> ppr t <> brackets (ppr n) - ppr (CreateArray t (Right vs)) = text "new" <+> ppr t <> text "[]" <+> braces(commasep $ map ppr vs) - ppr (CreateSystemTuple exps) = text "Tuple.Create" <> parens(commasep $ map ppr exps) - ppr (Tuple exps) = parens(commasep $ map ppr exps) - ppr (Array exps) = braces(commasep $ map ppr exps) -- uhoh is this right? - ppr (Field obj field) = ppr obj <> dot <> text field - ppr (Lambda expr [Exp e]) = ppr expr <+> text "=>" <+> ppr e - ppr (Lambda expr stmts) = ppr expr <+> text "=>" <+> braces(stack $ map ppr stmts) - ppr (Collection collection exps) = text "new" <+> text collection <> braces(commasep $ map ppr exps) - ppr (This e) = text "this" <> dot <> ppr e - ppr Null = text "null" - ppr (AllocArray t len) = text "new" <+> ppr t <> lbracket <> ppr len <> rbracket - -data CSIdx = IdxRange CSExp CSExp - | IdxExp CSExp - deriving (Eq, Show) - -data CSArg = ArgKeyword String CSArg -- please don't assign multiple keywords with the same argument - | Arg (Maybe ArgMemType) CSExp - deriving (Eq, Show) - -instance Pretty CSArg where - ppr (ArgKeyword kw arg) = text kw <> colon <+> ppr arg - ppr (Arg (Just mt) arg) = ppr mt <+> ppr arg - ppr (Arg Nothing arg) = ppr arg - -data CSStmt = If CSExp [CSStmt] [CSStmt] - | Try [CSStmt] [CSExcept] - | While CSExp [CSStmt] - | For String CSExp [CSStmt] - | ForEach String CSExp [CSStmt] - | UsingWith CSStmt [CSStmt] - | Unsafe [CSStmt] - | Fixed CSExp CSExp [CSStmt] - | Assign CSExp CSExp - | Reassign CSExp CSExp - | AssignOp String CSExp CSExp - | AssignTyped CSType CSExp (Maybe CSExp) - - | Comment String [CSStmt] - | Assert CSExp [CSExp] - | Throw CSExp - | Exp CSExp - | Return CSExp - | Pass - -- Definition-like statements. - | Using (Maybe String) String - | StaticFunDef CSFunDef - | PublicFunDef CSFunDef - | PrivateFunDef CSFunDef - | Namespace String [CSStmt] - | ClassDef CSClassDef - | ConstructorDef CSConstructorDef - | StructDef String [(CSType, String)] - - -- Some arbitrary string of CS code. - | Escape String - deriving (Eq, Show) - -instance Pretty CSStmt where - ppr (If cond tbranch []) = - text "if" <+> parens(ppr cond) - lbrace - indent 4 (stack $ map ppr tbranch) - rbrace - - ppr (If cond tbranch fbranch) = - text "if" <+> parens(ppr cond) - lbrace - indent 4 (stack $ map ppr tbranch) - rbrace - text "else" - lbrace - indent 4 (stack $ map ppr fbranch) - rbrace - - ppr (Try stmts excepts) = - text "try" - lbrace - indent 4 (stack $ map ppr stmts) - rbrace - stack (map ppr excepts) - - ppr (While cond body) = - text "while" <+> parens(ppr cond) - lbrace - indent 4 (stack $ map ppr body) - rbrace - - ppr (For i what body) = - text "for" <+> parens(initialize <> limit <> inc) - lbrace - indent 4 (stack $ map ppr body) - rbrace - where initialize = text "int" <+> text i <+> text "= 0" <+> semi - limit = text i <+> langle <+> ppr what <+> semi - inc = text i <> text "++" - - ppr (ForEach i what body) = - text "foreach" <+> parens initialize - lbrace - indent 4 (stack $ map ppr body) - rbrace - where initialize = text "var" <+> text i <+> text "in " <+> ppr what - - ppr (Using (Just as) from) = - text "using" <+> text as <+> text "=" <+> text from <> semi - - ppr (Using Nothing from) = - text "using" <+> text from <> semi - - ppr (Unsafe stmts) = - text "unsafe" - lbrace - indent 4 (stack $ map ppr stmts) - rbrace - - ppr (Fixed ptr e stmts) = - text "fixed" <+> parens(text "void*" <+> ppr ptr <+> text "=" <+> ppr e) - lbrace - indent 4 (stack $ map ppr stmts) - rbrace - - ppr (UsingWith assignment body) = - text "using" <+> parens(ppr assignment) - lbrace - indent 4 (stack $ map ppr body) - rbrace - - ppr (Assign e1 e2) = text "var" <+> ppr e1 <+> equals <+> ppr e2 <> semi - ppr (Reassign e1 e2) = ppr e1 <+> equals <+> ppr e2 <> semi - ppr (AssignTyped t e1 Nothing) = ppr t <+> ppr e1 <> semi - ppr (AssignTyped t e1 (Just e2)) = ppr t <+> ppr e1 <+> equals <+> ppr e2 <> semi - - ppr (AssignOp op e1 e2) = ppr e1 <+> text (op ++ "=") <+> ppr e2 <> semi - - ppr (Comment s body) = text "//" <> text s stack (map ppr body) - - ppr (Assert e []) = - text "FutharkAssert" <> parens(ppr e) <> semi - - ppr (Assert e exps) = - let exps' = stack $ intersperse (text ",") $ map ppr exps - formattedString = text "String.Format" <> parens exps' - in text "FutharkAssert" <> parens(ppr e <> text "," <+> formattedString) <> semi - - ppr (Throw e) = text "throw" <+> ppr e <> semi - - ppr (Exp e) = ppr e <> semi - - ppr (Return e) = text "return" <+> ppr e <> semi - - ppr (ClassDef d) = ppr d - - ppr (StaticFunDef d) = text "static" <+> ppr d - - ppr (PublicFunDef d) = text "public" <+> ppr d - - ppr (PrivateFunDef d) = text "private" <+> ppr d - - ppr (ConstructorDef d) = ppr d - - ppr (StructDef name assignments) = text "public struct" <+> text name <> braces(stack $ map (\(tp,field) -> text "public" <+> ppr tp <+> text field <> semi) assignments) - - ppr (Namespace name csstms) = text "namespace" <+> text name - lbrace - indent 4 (stack $ map ppr csstms) - rbrace - - ppr (Escape s) = stack $ map text $ lines s - - ppr Pass = empty - -instance Pretty CSFunDef where - ppr (Def fname retType args stmts) = - ppr retType <+> text fname <> parens( commasep(map ppr' args) ) - lbrace - indent 4 (stack (map ppr stmts)) - rbrace - where ppr' (tp, var) = ppr tp <+> text var - -instance Pretty CSClassDef where - ppr (Class cname body) = - text "class" <+> text cname - lbrace - indent 4 (stack (map ppr body)) - rbrace - - ppr (PublicClass cname body) = - text "public" <+> text "class" <+> text cname - lbrace - indent 4 (stack (map ppr body)) - rbrace - -instance Pretty CSConstructorDef where - ppr (ClassConstructor cname params body) = - text "public" <+> text cname <> parens(commasep $ map ppr' params) - lbrace - indent 4 (stack (map ppr body)) - rbrace - where ppr' (tp, var) = ppr tp <+> text var - -instance Pretty CSExcept where - ppr (Catch csexp stmts) = - text "catch" <+> parens(ppr csexp <+> text "e") - lbrace - indent 4 (stack (map ppr stmts)) - rbrace - -data CSExcept = Catch CSExp [CSStmt] - deriving (Eq, Show) - -type CSFunDefArg = (CSType, String) -data CSFunDef = Def String CSType [CSFunDefArg] [CSStmt] - deriving (Eq, Show) - -data CSClassDef = Class String [CSStmt] - | PublicClass String [CSStmt] - deriving (Eq, Show) - -data CSConstructorDef = ClassConstructor String [CSFunDefArg] [CSStmt] - deriving (Eq, Show) - -newtype CSProg = CSProg [CSStmt] - deriving (Eq, Show) - -instance Pretty CSProg where - ppr (CSProg stms) = stack (map ppr stms) diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp/Definitions.hs b/src/Futhark/CodeGen/Backends/GenericCSharp/Definitions.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/GenericCSharp/Definitions.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Futhark.CodeGen.Backends.GenericCSharp.Definitions - ( csReader - , csMemory - , csMemoryOpenCL - , csScalar - , csPanic - , csExceptions - , csOpenCL - ) where - -import Data.FileEmbed - -csMemory :: String -csMemory = $(embedStringFile "rts/csharp/memory.cs") - -csScalar :: String -csScalar = $(embedStringFile "rts/csharp/scalar.cs") - -csReader :: String -csReader = $(embedStringFile "rts/csharp/reader.cs") - -csPanic :: String -csPanic = $(embedStringFile "rts/csharp/panic.cs") - -csExceptions :: String -csExceptions = $(embedStringFile "rts/csharp/exceptions.cs") - -csOpenCL :: String -csOpenCL = $(embedStringFile "rts/csharp/opencl.cs") - -csMemoryOpenCL :: String -csMemoryOpenCL = $(embedStringFile "rts/csharp/memory_opencl.cs") diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp/Options.hs b/src/Futhark/CodeGen/Backends/GenericCSharp/Options.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/GenericCSharp/Options.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | This module defines a generator for @getopt@ based command --- line argument parsing. Each option is associated with arbitrary --- Python code that will perform side effects, usually by setting some --- global variables. -module Futhark.CodeGen.Backends.GenericCSharp.Options - ( Option (..) - , OptionArgument (..) - , generateOptionParser - ) - where - -import Futhark.CodeGen.Backends.GenericCSharp.AST - --- | Specification if a single command line option. The option must --- have a long name, and may also have a short name. --- --- When the statement is being executed, the argument (if any) will be --- stored in the variable @optarg@. -data Option = Option { optionLongName :: String - , optionShortName :: Maybe Char - , optionArgument :: OptionArgument - , optionAction :: [CSStmt] - } - --- | Whether an option accepts an argument. -data OptionArgument = NoArgument - | RequiredArgument - | OptionalArgument - --- | Generate option parsing code that accepts the given command line options. Will read from @sys.argv@. --- --- If option parsing fails for any reason, the entire process will --- terminate with error code 1. -generateOptionParser :: [Option] -> [CSStmt] -generateOptionParser options = - [ Assign (Var "options") (Collection "OptionSet" $ map parseOption options) - , Assign (Var "extra") (Call (Var "options.Parse") [Arg Nothing (Var "args")]) - ] - where parseOption option = Array [ String $ option_string option - , Lambda (Var "optarg") $ optionAction option ] - option_string option = case optionArgument option of - RequiredArgument -> - concat [maybe "" prefix $ optionShortName option,optionLongName option,"="] - _ -> - maybe "" prefix (optionShortName option) ++ optionLongName option - prefix = flip (:) "|" 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 @@ -12,6 +12,7 @@ , compileVar , compileDim , compileExp + , compilePrimExp , compileCode , compilePrimValue , compilePrimType @@ -674,7 +675,8 @@ [BinOp "-" (toMicroseconds (Var "time_end")) (toMicroseconds (Var "time_start"))]], - Exp $ simpleCall "runtime_file.write" [String "\n"]] + Exp $ simpleCall "runtime_file.write" [String "\n"], + Exp $ simpleCall "runtime_file.flush" []] toMicroseconds x = simpleCall "int" [BinOp "*" x $ Integer 1000000] @@ -689,11 +691,12 @@ USignum{} -> "usignum" compileBinOpLike :: Monad m => - Imp.Exp -> Imp.Exp - -> CompilerM op s (PyExp, PyExp, String -> m PyExp) -compileBinOpLike x y = do - x' <- compileExp x - y' <- compileExp y + (v -> m PyExp) + -> Imp.PrimExp v -> Imp.PrimExp v + -> m (PyExp, PyExp, String -> m PyExp) +compileBinOpLike f x y = do + x' <- compilePrimExp f x + y' <- compilePrimExp f y let simple s = return $ BinOp s x' y' return (x', y', simple) @@ -785,30 +788,15 @@ compileVar v = asks $ fromMaybe (Var $ compileName v) . M.lookup v . envVarExp -compileExp :: Imp.Exp -> CompilerM op s PyExp - -compileExp (Imp.ValueExp v) = return $ compilePrimValue v - -compileExp (Imp.LeafExp (Imp.ScalarVar vname) _) = - compileVar vname - -compileExp (Imp.LeafExp (Imp.SizeOf t) _) = - return $ simpleCall (compilePrimToNp $ IntType Int32) [Integer $ primByteSize t] +-- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you. +compilePrimExp :: Monad m => (v -> m PyExp) -> Imp.PrimExp v -> m PyExp -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) = - join $ asks envReadScalar - <*> compileVar src <*> compileExp iexp - <*> pure restype <*> pure space +compilePrimExp _ (Imp.ValueExp v) = return $ compilePrimValue v -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt _ _) _) = do - iexp' <- compileExp iexp - let bt' = compilePrimType bt - nptype = compilePrimToNp bt - src' <- compileVar src - return $ simpleCall "indexArray" [src', iexp', Var bt', Var nptype] +compilePrimExp f (Imp.LeafExp v _) = f v -compileExp (Imp.BinOpExp op x y) = do - (x', y', simple) <- compileBinOpLike x y +compilePrimExp f (Imp.BinOpExp op x y) = do + (x', y', simple) <- compileBinOpLike f x y case op of Add{} -> simple "+" Sub{} -> simple "-" @@ -826,12 +814,12 @@ LogOr{} -> simple "or" _ -> return $ simpleCall (pretty op) [x', y'] -compileExp (Imp.ConvOpExp conv x) = do - x' <- compileExp x +compilePrimExp f (Imp.ConvOpExp conv x) = do + x' <- compilePrimExp f x return $ simpleCall (pretty conv) [x'] -compileExp (Imp.CmpOpExp cmp x y) = do - (x', y', simple) <- compileBinOpLike x y +compilePrimExp f (Imp.CmpOpExp cmp x y) = do + (x', y', simple) <- compileBinOpLike f x y case cmp of CmpEq{} -> simple "==" FCmpLt{} -> simple "<" @@ -840,11 +828,31 @@ CmpLle -> simple "<=" _ -> return $ simpleCall (pretty cmp) [x', y'] -compileExp (Imp.UnOpExp op exp1) = - UnOp (compileUnOp op) <$> compileExp exp1 +compilePrimExp f (Imp.UnOpExp op exp1) = + UnOp (compileUnOp op) <$> compilePrimExp f exp1 -compileExp (Imp.FunExp h args _) = - simpleCall (futharkFun (pretty h)) <$> mapM compileExp args +compilePrimExp f (Imp.FunExp h args _) = + simpleCall (futharkFun (pretty h)) <$> mapM (compilePrimExp f) args + +compileExp :: Imp.Exp -> CompilerM op s PyExp +compileExp = compilePrimExp compileLeaf + where compileLeaf (Imp.ScalarVar vname) = + compileVar vname + + compileLeaf (Imp.SizeOf t) = + return $ simpleCall (compilePrimToNp $ IntType Int32) [Integer $ primByteSize t] + + compileLeaf (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) = + join $ asks envReadScalar + <*> compileVar src <*> compileExp iexp + <*> pure restype <*> pure space + + compileLeaf (Imp.Index src (Imp.Count iexp) bt _ _) = do + iexp' <- compileExp iexp + let bt' = compilePrimType bt + nptype = compilePrimToNp bt + src' <- compileVar src + return $ simpleCall "indexArray" [src', iexp', Var bt', Var nptype] compileCode :: Imp.Code op -> CompilerM op s () diff --git a/src/Futhark/CodeGen/Backends/GenericPython/AST.hs b/src/Futhark/CodeGen/Backends/GenericPython/AST.hs --- a/src/Futhark/CodeGen/Backends/GenericPython/AST.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython/AST.hs @@ -37,6 +37,7 @@ | List [PyExp] | Field PyExp String | Dict [(PyExp, PyExp)] + | Lambda String PyExp | None deriving (Eq, Show) @@ -115,7 +116,7 @@ ppr (List es) = brackets $ commasep $ map ppr es ppr (Dict kvs) = braces $ commasep $ map ppElem kvs where ppElem (k, v) = ppr k <> colon <+> ppr v - + ppr (Lambda p e) = text "lambda" <+> text p <> text ":" <+> ppr e ppr None = text "None" instance Pretty PyStmt where 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,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} module Futhark.CodeGen.Backends.PyOpenCL ( compileProg ) where @@ -15,17 +16,20 @@ import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.MonadFreshNames +import Futhark.Util (zEncodeString) --maybe pass the config file rather than multiple arguments compileProg :: MonadFreshNames m => - Maybe String -> Prog KernelsMem -> m String + Maybe String -> Prog KernelsMem -> m (ImpGen.Warnings, String) compileProg module_name prog = do - Imp.Program opencl_code opencl_prelude kernels types sizes failures prog' <- + (ws, Imp.Program opencl_code opencl_prelude + kernels types sizes failures prog') <- ImpGen.compileProg prog --prepare the strings for assigning the kernels and set them as global let assign = unlines $ - map (\x -> pretty $ Assign (Var ("self."++x++"_var")) - (Var $ "program."++x)) $ + map (\x -> pretty $ + Assign (Var ("self."++zEncodeString (nameToString x)++"_var")) + (Var $ "program."++zEncodeString (nameToString x))) $ M.keys kernels let defines = @@ -108,7 +112,8 @@ } ] - Py.compileProg module_name constructor imports defines operations () + (ws,) <$> + Py.compileProg module_name constructor imports defines operations () [Exp $ Py.simpleCall "sync" [Var "self"]] options prog' where operations :: Py.Operations Imp.OpenCL () operations = Py.Operations @@ -158,12 +163,12 @@ where mult_exp = BinOp "*" -launchKernel :: String -> Imp.Safety -> [PyExp] -> [PyExp] -> [Imp.KernelArg] +launchKernel :: Imp.KernelName -> Imp.KernelSafety -> [PyExp] -> [PyExp] -> [Imp.KernelArg] -> Py.CompilerM op s () launchKernel kernel_name safety kernel_dims workgroup_dims args = do let kernel_dims' = Tuple kernel_dims workgroup_dims' = Tuple workgroup_dims - kernel_name' = "self." ++ kernel_name ++ "_var" + kernel_name' = "self." ++ zEncodeString (nameToString kernel_name) ++ "_var" args' <- mapM processKernelArg args let failure_args = take (Imp.numFailureParams safety) [Var "self.global_failure", diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -7,6 +7,7 @@ , openClPrelude ) where +import Control.Monad.Identity import Data.FileEmbed import qualified Data.Map as M import qualified Data.Text as T @@ -17,6 +18,7 @@ FailureMsg(..), ErrorMsg(..), ErrorMsgPart(..), errorMsgArgTypes) import Futhark.CodeGen.OpenCL.Heuristics import Futhark.CodeGen.Backends.GenericPython.AST +import qualified Futhark.CodeGen.Backends.GenericPython as Py import Futhark.Util.Pretty (prettyText) errorMsgNumArgs :: ErrorMsg a -> Int @@ -94,6 +96,8 @@ TileSize -> String "tile_size" Threshold -> String "threshold" - what' = case what of - HeuristicConst x -> Integer $ toInteger x - HeuristicDeviceInfo s -> String s + what' = Lambda "device" $ runIdentity $ Py.compilePrimExp onLeaf what + + onLeaf (DeviceInfo s) = + pure $ Py.simpleCall "device.get_info" + [Py.simpleCall "getattr" [Var "cl.device_info", String s]] 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 @@ -20,9 +20,10 @@ import Futhark.MonadFreshNames -- | Compile the program to sequential C. -compileProg :: MonadFreshNames m => Prog SeqMem -> m GC.CParts +compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, GC.CParts) compileProg = - GC.compileProg operations generateContext "" [DefaultSpace] [] <=< + traverse + (GC.compileProg "c" operations generateContext "" [DefaultSpace] []) <=< ImpGen.compileProg where operations :: GC.Operations Imp.Sequential () operations = GC.defaultOperations diff --git a/src/Futhark/CodeGen/Backends/SequentialCSharp.hs b/src/Futhark/CodeGen/Backends/SequentialCSharp.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/SequentialCSharp.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Futhark.CodeGen.Backends.SequentialCSharp - ( compileProg - ) where - -import Control.Monad - -import Futhark.IR.SeqMem -import qualified Futhark.CodeGen.ImpCode.Sequential as Imp -import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen -import qualified Futhark.CodeGen.Backends.GenericCSharp as CS -import Futhark.CodeGen.Backends.GenericCSharp.AST () -import Futhark.MonadFreshNames - -compileProg :: MonadFreshNames m => - Maybe String -> Prog SeqMem -> m String -compileProg module_name = - ImpGen.compileProg >=> - CS.compileProg - module_name - CS.emptyConstructor - [] - [] - operations - () - empty - [] - [] - [] - where operations :: CS.Operations Imp.Sequential () - operations = CS.defaultOperations - { CS.opsCompiler = const $ return () - , CS.opsCopy = copySequentialMemory - } - empty = return () - -copySequentialMemory :: CS.Copy Imp.Sequential () -copySequentialMemory destmem destidx DefaultSpace srcmem srcidx DefaultSpace nbytes _bt = - CS.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes -copySequentialMemory _ _ destspace _ _ srcspace _ _ = - error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace 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 @@ -13,15 +13,15 @@ import Futhark.MonadFreshNames compileProg :: MonadFreshNames m => - Maybe String -> Prog SeqMem -> m String + Maybe String -> Prog SeqMem -> m (ImpGen.Warnings, String) compileProg module_name = ImpGen.compileProg >=> - GenericPython.compileProg - module_name - GenericPython.emptyConstructor - imports - defines - operations () [] [] + traverse (GenericPython.compileProg + module_name + GenericPython.emptyConstructor + imports + defines + operations () [] []) where imports = [Import "sys" Nothing, Import "numpy" $ Just "np", Import "ctypes" $ Just "ct", 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 @@ -77,9 +77,9 @@ cIntOps = concatMap (`map` [minBound..maxBound]) ops ++ cIntPrimFuns where ops = [mkAdd, mkSub, mkMul, - mkUDiv, mkUMod, - mkSDiv, mkSMod, - mkSQuot, mkSRem, + mkUDiv, mkUDivUp, mkUMod, mkUDivSafe, mkUDivUpSafe, mkUModSafe, + mkSDiv, mkSDivUp, mkSMod, mkSDivSafe, mkSDivUpSafe, mkSModSafe, + mkSQuot, mkSRem, mkSQuotSafe, mkSRemSafe, mkSMin, mkUMin, mkSMax, mkUMax, mkShl, mkLShr, mkAShr, @@ -102,7 +102,11 @@ mkSub = simpleUintOp "sub" [C.cexp|x - y|] mkMul = simpleUintOp "mul" [C.cexp|x * y|] mkUDiv = simpleUintOp "udiv" [C.cexp|x / y|] + mkUDivUp = simpleUintOp "udiv_up" [C.cexp|(x+y-1) / y|] mkUMod = simpleUintOp "umod" [C.cexp|x % y|] + mkUDivSafe = simpleUintOp "udiv_safe" [C.cexp|y == 0 ? 0 : x / y|] + mkUDivUpSafe = simpleUintOp "udiv_up_safe" [C.cexp|y == 0 ? 0 : (x+y-1) / y|] + mkUModSafe = simpleUintOp "umod_safe" [C.cexp|y == 0 ? 0 : x % y|] mkUMax = simpleUintOp "umax" [C.cexp|x < y ? y : x|] mkUMin = simpleUintOp "umin" [C.cexp|x < y ? x : y|] @@ -114,6 +118,8 @@ return q - (((r != 0) && ((r < 0) != (y < 0))) ? 1 : 0); }|] + mkSDivUp t = + simpleIntOp "sdiv_up" [C.cexp|$id:(taggedI "sdiv" t)(x+y-1,y)|] t mkSMod t = let ct = intTypeToCType t in [C.cedecl|static inline $ty:ct $id:(taggedI "smod" t)($ty:ct x, $ty:ct y) { @@ -121,9 +127,17 @@ return r + ((r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0)) ? 0 : y); }|] + mkSDivSafe t = + simpleIntOp "sdiv_safe" [C.cexp|y == 0 ? 0 : $id:(taggedI "sdiv" t)(x,y)|] t + mkSDivUpSafe t = + simpleIntOp "sdiv_up_safe" [C.cexp|$id:(taggedI "sdiv_safe" t)(x+y-1,y)|] t + mkSModSafe t = + simpleIntOp "smod_safe" [C.cexp|y == 0 ? 0 : $id:(taggedI "smod" t)(x,y)|] t mkSQuot = simpleIntOp "squot" [C.cexp|x / y|] mkSRem = simpleIntOp "srem" [C.cexp|x % y|] + mkSQuotSafe = simpleIntOp "squot_safe" [C.cexp|y == 0 ? 0 : x / y|] + mkSRemSafe = simpleIntOp "srem_safe" [C.cexp|y == 0 ? 0 : x % y|] mkSMax = simpleIntOp "smax" [C.cexp|x < y ? y : x|] mkSMin = simpleIntOp "smin" [C.cexp|x < y ? x : y|] mkShl = simpleUintOp "shl" [C.cexp|x << y|] 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,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE Strict #-} -- | Imperative intermediate language used as a stepping stone in code generation. -- -- This is a generic representation parametrised on an extensible @@ -22,7 +23,6 @@ , SubExp(..) , MemSize , DimSize - , Type (..) , Space (..) , SpaceId , Code (..) @@ -40,6 +40,7 @@ , ArrayContents(..) , lexicalMemoryUsage + , calledFuncs -- * Typed enumerations , Bytes @@ -58,6 +59,7 @@ where import Data.List (intersperse) +import qualified Data.Set as S import Data.Traversable import qualified Data.Map as M @@ -78,9 +80,6 @@ -- | The size of an array. type DimSize = SubExp --- | The type of a parameter. -data Type = Scalar PrimType | Mem Space - -- | An ImpCode function parameter. data Param = MemParam VName Space | ScalarParam VName PrimType @@ -92,7 +91,9 @@ paramName (ScalarParam name _) = name -- | A collection of imperative functions and constants. -data Definitions a = Definitions (Constants a) (Functions a) +data Definitions a = Definitions { defConsts :: Constants a + , defFuns :: Functions a + } -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)] @@ -283,6 +284,17 @@ set (SetMem x y _) = namesFromList [x,y] set x = go set x + +-- | The set of functions that are called by this code. Assumes there +-- are no function calls in 'Op's. +calledFuncs :: Code a -> S.Set Name +calledFuncs (x :>>: y) = calledFuncs x <> calledFuncs y +calledFuncs (If _ x y) = calledFuncs x <> calledFuncs y +calledFuncs (For _ _ _ x) = calledFuncs x +calledFuncs (While _ x) = calledFuncs x +calledFuncs (Comment _ x) = calledFuncs x +calledFuncs (Call _ f _) = S.singleton f +calledFuncs _ = mempty -- | The leaves of an 'Exp'. data ExpLeaf = ScalarVar VName diff --git a/src/Futhark/CodeGen/ImpCode/Kernels.hs b/src/Futhark/CodeGen/ImpCode/Kernels.hs --- a/src/Futhark/CodeGen/ImpCode/Kernels.hs +++ b/src/Futhark/CodeGen/ImpCode/Kernels.hs @@ -67,7 +67,7 @@ -- alphanumeric and without spaces. , kernelFailureTolerant :: Bool - -- ^ If true, this kernel does not need for check + -- ^ If true, this kernel does not need to check -- whether we are in a failing state, as it can cope. -- Intuitively, it means that the kernel does not -- depend on any non-scalar parameters to make control @@ -128,7 +128,7 @@ (text "groups" <+> brace (ppr $ kernelNumGroups kernel) text "group_size" <+> brace (ppr $ kernelGroupSize kernel) text "uses" <+> brace (commasep $ map ppr $ kernelUses kernel) - text "failure_tolerant" <+> ppr (kernelFailureTolerant kernel) + text "failure_tolerant" <+> brace (ppr $ kernelFailureTolerant kernel) text "body" <+> brace (ppr $ kernelBody kernel)) -- | When we do a barrier or fence, is it at the local or global diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -14,7 +14,7 @@ , KernelName , KernelArg (..) , OpenCL (..) - , Safety(..) + , KernelSafety(..) , numFailureParams , KernelTarget (..) , FailureMsg(..) @@ -35,7 +35,7 @@ data Program = Program { openClProgram :: String , openClPrelude :: String -- ^ Must be prepended to the program. - , openClKernelNames :: M.Map KernelName Safety + , openClKernelNames :: M.Map KernelName KernelSafety , openClUsedTypes :: [PrimType] -- ^ So we can detect whether the device is capable. , openClSizes :: M.Map Name SizeClass @@ -58,7 +58,7 @@ type Code = Imp.Code OpenCL -- | The name of a kernel. -type KernelName = String +type KernelName = Name -- | An argument to be passed to a kernel. data KernelArg = ValueKArg Exp PrimType @@ -76,7 +76,7 @@ -- | Information about bounds checks and how sensitive it is to -- errors. Ordered by least demanding to most. -data Safety +data KernelSafety = SafetyNone -- ^ Does not need to know if we are in a failing state, and also -- cannot fail. @@ -89,13 +89,13 @@ -- | How many leading failure arguments we must pass when launching a -- kernel with these safety characteristics. -numFailureParams :: Safety -> Int +numFailureParams :: KernelSafety -> Int numFailureParams SafetyNone = 0 numFailureParams SafetyCheap = 1 numFailureParams SafetyFull = 3 -- | Host-level OpenCL operation. -data OpenCL = LaunchKernel Safety KernelName [KernelArg] [Exp] [Exp] +data OpenCL = LaunchKernel KernelSafety KernelName [KernelArg] [Exp] [Exp] | GetSize VName Name | CmpSizeLe VName Name Exp | GetSizeMax VName SizeClass diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Strict #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} module Futhark.CodeGen.ImpGen ( -- * Entry Points @@ -22,6 +23,7 @@ -- * Monadic Compiler Interface , ImpM , localDefaultSpace, askFunction + , newVNameForFun, nameForFun , askEnv, localEnv , localOps , VTable @@ -80,12 +82,16 @@ , (<--) , function + + , warn + , module Language.Futhark.Warnings ) where import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer +import Control.Parallel.Strategies import Data.Bifunctor (first) import qualified Data.DList as DL import Data.Either @@ -104,6 +110,7 @@ import Futhark.Construct (fullSliceNum) import Futhark.MonadFreshNames import Futhark.Util +import Language.Futhark.Warnings -- | How to compile an t'Op'. type OpCompiler lore r op = Pattern lore -> Op lore -> ImpM lore r op () @@ -200,6 +207,9 @@ -- ^ User-extensible environment. , envFunction :: Maybe Name -- ^ Name of the function we are compiling, if any. + , envAttrs :: Attrs + -- ^ The set of attributes that are active on the enclosing + -- statements (including the one we are currently compiling). } newEnv :: r -> Operations lore r op -> Imp.Space -> Env lore r op @@ -213,6 +223,7 @@ , envVolatility = Imp.Nonvolatile , envEnv = r , envFunction = Nothing + , envAttrs = mempty } -- | The symbol table used during compilation. @@ -222,11 +233,12 @@ ImpState { stateVTable :: VTable lore , stateFunctions :: Imp.Functions op , stateCode :: Imp.Code op + , stateWarnings :: Warnings , stateNameSource :: VNameSource } newState :: VNameSource -> ImpState lore r op -newState = ImpState mempty mempty mempty +newState = ImpState mempty mempty mempty mempty newtype ImpM lore r op a = ImpM (ReaderT (Env lore r op) (State (ImpState lore r op)) a) @@ -278,10 +290,12 @@ , stateFunctions = mempty , stateCode = mempty , stateNameSource = stateNameSource s + , stateWarnings = mempty } (x, s'') = runState (runReaderT m env') s' putNameSource $ stateNameSource s'' + warnings $ stateWarnings s'' return (x, stateCode s'') -- | Execute a code generation action, returning the code that was @@ -308,6 +322,14 @@ emit :: Imp.Code op -> ImpM lore r op () emit code = modify $ \s -> s { stateCode = stateCode s <> code } +warnings :: Warnings -> ImpM lore r op () +warnings ws = modify $ \s -> s { stateWarnings = ws <> stateWarnings s} + +-- | Emit a warning about something the user should be aware of. +warn :: Located loc => loc -> [loc] -> String -> ImpM lore r op () +warn loc locs problem = + warnings $ singleWarning' (srclocOf loc) (map srclocOf locs) problem + -- | Emit a function in the generated code. emitFunction :: Name -> Imp.Function op -> ImpM lore r op () emitFunction fname fun = do @@ -328,22 +350,31 @@ compileProg :: (Mem lore, FreeIn op, MonadFreshNames m) => r -> Operations lore r op -> Imp.Space - -> Prog lore -> m (Imp.Definitions op) + -> Prog lore -> m (Warnings, Imp.Definitions op) compileProg r ops space (Prog consts funs) = modifyNameSource $ \src -> - let (consts', s') = - runImpM compile r ops space - (newState src) { stateVTable = constsVTable consts } - in (Imp.Definitions consts' (stateFunctions s'), + let (_, ss) = + unzip $ parMap rpar (compileFunDef' src) funs + free_in_funs = + freeIn $ mconcat $ map stateFunctions ss + (consts', s') = + runImpM (compileConsts free_in_funs consts) r ops space $ + combineStates ss + in ((stateWarnings s', + Imp.Definitions consts' (stateFunctions s')), stateNameSource s') - where compile = do - mapM_ compileFunDef' funs - free_in_funs <- gets (freeIn . stateFunctions) - compileConsts free_in_funs consts + where compileFunDef' src fdef = + runImpM (compileFunDef fdef) r ops space + (newState src) { stateVTable = constsVTable consts } - compileFunDef' fdef = - local (\env -> env { envFunction = Just $ funDefName fdef }) $ - compileFunDef fdef + combineStates ss = + let Imp.Functions funs' = mconcat $ map stateFunctions ss + src = mconcat (map stateNameSource ss) + in (newState src) { stateFunctions = + Imp.Functions $ M.toList $ M.fromList funs' + , stateWarnings = + mconcat $ map stateWarnings ss + } compileConsts :: Names -> Stms lore -> ImpM lore r op (Imp.Constants op) compileConsts used_consts stms = do @@ -495,7 +526,8 @@ compileFunDef :: Mem lore => FunDef lore -> ImpM lore r op () -compileFunDef (FunDef entry fname rettype params body) = do +compileFunDef (FunDef entry _ fname rettype params body) = + local (\env -> env { envFunction = Just fname }) $ do ((outparams, inparams, results, args), body') <- collect' compile emitFunction fname $ Imp.Function (isJust entry) outparams inparams body' results args where params_entry = maybe (replicate (length params) TypeDirect) fst entry @@ -559,10 +591,11 @@ -- Free. This is very conservative, but can cut down on lifetimes -- in some cases. void $ compileStms' mempty $ stmsToList all_stms - where compileStms' allocs (Let pat _ e:bs) = do + where compileStms' allocs (Let pat aux e:bs) = do dVars (Just e) (patternElements pat) - e_code <- collect $ compileExp pat e + e_code <- localAttrs (stmAuxAttrs aux) $ + collect $ compileExp pat e (live_after, bs_code) <- collect' $ compileStms' (patternAllocs pat <> allocs) bs let dies_here v = not (v `nameIn` live_after) && v `nameIn` freeIn e_code @@ -675,6 +708,10 @@ msg' <- traverse toExp msg emit $ Imp.Assert e' msg' loc + attrs <- askAttrs + when (AttrComp "warn" ["safety_checks"] `inAttrs` attrs) $ + uncurry warn loc "Safety check required at run-time." + defCompileBasicOp (Pattern _ [pe]) (Index src slice) | Just idxs <- sliceIndices slice = copyDWIM (patElemName pe) [] (Var src) $ map (DimFix . toExp' int32) idxs @@ -730,7 +767,7 @@ dest_mem <- entryArrayLocation <$> lookupArray (patElemName pe) dest_space <- entryMemSpace <$> lookupMemory (memLocationName dest_mem) let t = primValueType v - static_array <- newVName "static_array" + static_array <- newVNameForFun "static_array" emit $ Imp.DeclareArray static_array dest_space t $ Imp.ArrayValues vs let static_src = MemLocation static_array [intConst Int32 $ fromIntegral $ length es] $ IxFun.iota [fromIntegral $ length es] @@ -754,9 +791,6 @@ defCompileBasicOp _ Reshape{} = return () -defCompileBasicOp _ Repeat{} = - return () - defCompileBasicOp pat e = error $ "ImpGen.defCompileBasicOp: Invalid pattern\n " ++ pretty pat ++ "\nfor expression\n " ++ pretty e @@ -914,12 +948,33 @@ askFunction :: ImpM lore r op (Maybe Name) askFunction = asks envFunction +-- | Generate a 'VName', prefixed with 'askFunction' if it exists. +newVNameForFun :: String -> ImpM lore r op VName +newVNameForFun s = do + fname <- fmap nameToString <$> askFunction + newVName $ maybe "" (++".") fname ++ s + +-- | Generate a 'Name', prefixed with 'askFunction' if it exists. +nameForFun :: String -> ImpM lore r op Name +nameForFun s = do + fname <- askFunction + return $ maybe "" (<>".") fname <> nameFromString s + askEnv :: ImpM lore r op r askEnv = asks envEnv localEnv :: (r -> r) -> ImpM lore r op a -> ImpM lore r op a localEnv f = local $ \env -> env { envEnv = f $ envEnv env } +-- | The active attributes, including those for the statement +-- currently being compiled. +askAttrs :: ImpM lore r op Attrs +askAttrs = asks envAttrs + +-- | Add more attributes to what is returning by 'askAttrs'. +localAttrs :: Attrs -> ImpM lore r op a -> ImpM lore r op a +localAttrs attrs = local $ \env -> env { envAttrs = attrs <> envAttrs env } + localOps :: Operations lore r op -> ImpM lore r op a -> ImpM lore r op a localOps ops = local $ \env -> env { envExpCompiler = opsExpCompiler ops @@ -1149,7 +1204,8 @@ emit $ Imp.SetScalar name $ Imp.index mem i bt space vol | otherwise -> error $ - unwords ["copyDWIMDest: prim-typed target and array-typed source", pretty src, + unwords ["copyDWIMDest: prim-typed target", pretty name, + "and array-typed source", pretty src, "with slice", pretty src_slice] (ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do @@ -1212,10 +1268,12 @@ error $ "compileAlloc: Invalid pattern: " ++ pretty pat -- | The number of bytes needed to represent the array in a --- straightforward contiguous format. +-- straightforward contiguous format, as an 'Int64' expression. typeSize :: Type -> Count Bytes Imp.Exp -typeSize t = Imp.bytes $ Imp.LeafExp (Imp.SizeOf $ elemType t) int32 * - product (map (toExp' int32) (arrayDims t)) +typeSize t = + Imp.bytes $ i64 (Imp.LeafExp (Imp.SizeOf $ elemType t) int32) * + product (map (i64 . toExp' int32) (arrayDims t)) + where i64 = ConvOpExp (SExt Int32 Int64) --- Building blocks for constructing code. @@ -1312,7 +1370,7 @@ let num_elems = case vs of Imp.ArrayValues vs' -> length vs' Imp.ArrayZeros n -> fromIntegral n shape = Shape [intConst Int32 $ toInteger num_elems] - mem <- newVName $ name ++ "_mem" + mem <- newVNameForFun $ name ++ "_mem" emit $ Imp.DeclareArray mem space pt vs addVar mem $ MemVar Nothing $ MemEntry space sArray name pt shape $ ArrayIn mem $ IxFun.iota [fromIntegral num_elems] @@ -1340,15 +1398,17 @@ x <-- e = emit $ Imp.SetScalar x e infixl 3 <-- --- | Constructing a non-entry point function. -function :: [Imp.Param] -> [Imp.Param] -> ImpM lore r op () - -> ImpM lore r op (Imp.Function op) -function outputs inputs m = do +-- | Constructing an ad-hoc function that does not +-- correspond to any of the IR functions in the input program. +function :: Name -> [Imp.Param] -> [Imp.Param] -> ImpM lore r op () + -> ImpM lore r op () +function fname outputs inputs m = local newFunction $ do body <- collect $ do mapM_ addParam $ outputs ++ inputs m - return $ Imp.Function False outputs inputs body [] [] + emitFunction fname $ Imp.Function False outputs inputs body [] [] where addParam (Imp.MemParam name space) = addVar name $ MemVar Nothing $ MemEntry space addParam (Imp.ScalarParam name bt) = addVar name $ ScalarVar Nothing $ ScalarEntry bt + newFunction env = env { envFunction = Just fname } 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,12 +1,15 @@ module Futhark.CodeGen.ImpGen.CUDA ( compileProg + , Warnings ) where +import Data.Bifunctor (second) + import Futhark.IR.KernelsMem -import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL -import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.ImpGen.Kernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog KernelsMem -> m OpenCL.Program -compileProg prog = kernelsToCUDA <$> ImpGenKernels.compileProgCUDA prog +compileProg :: MonadFreshNames m => Prog KernelsMem -> m (Warnings, Program) +compileProg prog = second kernelsToCUDA <$> compileProgCUDA prog diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs @@ -9,12 +9,15 @@ module Futhark.CodeGen.ImpGen.Kernels ( compileProgOpenCL , compileProgCUDA + , Warnings ) where import Control.Monad.Except +import Data.Bifunctor (second) +import qualified Data.Map as M import Data.Maybe -import Data.List () +import Data.List (foldl') import Prelude hiding (quot) @@ -33,7 +36,7 @@ import Futhark.CodeGen.ImpGen.Kernels.Transpose import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.CodeGen.SetDefaultSpace -import Futhark.Util.IntegralExp (quot, quotRoundingUp, IntegralExp) +import Futhark.Util.IntegralExp (quot, divUp, IntegralExp) callKernelOperations :: Operations KernelsMem HostEnv Imp.HostOp callKernelOperations = @@ -57,13 +60,16 @@ ] cuda = opencl ++ [(FAdd Float32, Imp.AtomicFAdd Float32)] -compileProg :: MonadFreshNames m => HostEnv -> Prog KernelsMem -> m Imp.Program +compileProg :: MonadFreshNames m => HostEnv -> Prog KernelsMem + -> m (Warnings, Imp.Program) compileProg env prog = - setDefaultSpace (Imp.Space "device") <$> + second (setDefaultSpace (Imp.Space "device")) <$> Futhark.CodeGen.ImpGen.compileProg env callKernelOperations (Imp.Space "device") prog +-- | Compile a 'KernelsMem' program to low-level parallel code, with +-- either CUDA or OpenCL characteristics. compileProgOpenCL, compileProgCUDA - :: MonadFreshNames m => Prog KernelsMem -> m Imp.Program + :: MonadFreshNames m => Prog KernelsMem -> m (Warnings, Imp.Program) compileProgOpenCL = compileProg $ HostEnv openclAtomics compileProgCUDA = compileProg $ HostEnv cudaAtomics @@ -99,7 +105,7 @@ -- The calculations are done with 64-bit integers to avoid overflow -- issues. let num_groups_maybe_zero = BinOpExp (SMin Int64) - (toExp' int64 w64 `quotRoundingUp` + (toExp' int64 w64 `divUp` i64 (toExp' int32 group_size)) $ i64 (Imp.vi32 max_num_groups) -- We also don't want zero groups. @@ -135,6 +141,39 @@ segOpCompiler pat segop = compilerBugS $ "segOpCompiler: unexpected " ++ pretty (segLevel segop) ++ " for rhs of pattern " ++ pretty pat +-- Create boolean expression that checks whether all kernels in the +-- enclosed code do not use more local memory than we have available. +-- We look at *all* the kernels here, even those that might be +-- otherwise protected by their own multi-versioning branches deeper +-- down. Currently the compiler will not generate multi-versioning +-- that makes this a problem, but it might in the future. +checkLocalMemoryReqs :: Imp.Code -> CallKernelGen (Maybe Imp.Exp) +checkLocalMemoryReqs code = do + scope <- askScope + let alloc_sizes = map (sum . localAllocSizes . Imp.kernelBody) $ getKernels code + + -- If any of the sizes involve a variable that is not known at this + -- point, then we cannot check the requirements. + if any (`M.notMember` scope) (namesToList $ freeIn alloc_sizes) + then return Nothing + else do + local_memory_capacity <- dPrim "local_memory_capacity" int32 + sOp $ Imp.GetSizeMax local_memory_capacity SizeLocalMemory + + let local_memory_capacity_64 = + ConvOpExp (SExt Int32 Int64) $ Imp.vi32 local_memory_capacity + fits size = + unCount size .<=. local_memory_capacity_64 + return $ Just $ foldl' (.&&.) true (map fits alloc_sizes) + + where getKernels = foldMap getKernel + getKernel (Imp.CallKernel k) = [k] + getKernel _ = [] + + localAllocSizes = foldMap localAllocSize + localAllocSize (Imp.LocalAlloc _ size) = [size] + localAllocSize _ = [] + expCompiler :: ExpCompiler KernelsMem HostEnv Imp.HostOp -- We generate a simple kernel for itoa and replicate. @@ -151,6 +190,20 @@ -- Allocation in the "local" space is just a placeholder. expCompiler _ (Op (Alloc _ (Space "local"))) = return () + +-- This is a multi-versioning If created by incremental flattening. +-- We need to augment the conditional with a check that any local +-- memory requirements in tbranch are compatible with the hardware. +-- We do not check anything for fbranch, as we assume that it will +-- always be safe (and what would we do if none of the branches would +-- work?). +expCompiler dest (If cond tbranch fbranch (IfDec _ IfEquiv)) = do + tcode <- collect $ compileBody dest tbranch + fcode <- collect $ compileBody dest fbranch + check <- checkLocalMemoryReqs tcode + emit $ case check of + Nothing -> fcode + Just ok -> Imp.If (ok .&&. toExp' Bool cond) tcode fcode expCompiler dest e = defCompileExp dest e diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs @@ -48,7 +48,7 @@ import qualified Futhark.IR.Mem.IxFun as IxFun import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpGen -import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) +import Futhark.Util.IntegralExp (divUp, quot, rem) import Futhark.Util (chunks, maybeNth, mapAccumLM, takeLast, dropLast) newtype HostEnv = HostEnv @@ -159,7 +159,7 @@ else do -- Compute how many elements this thread is responsible for. -- Formula: (n - tid) / num_threads (rounded up). - let elems_for_this = (n - tid) `quotRoundingUp` num_threads + let elems_for_this = (n - tid) `divUp` num_threads sFor "i" elems_for_this $ \i -> f $ i * num_threads + tid @@ -301,10 +301,27 @@ let segment_size = last dims' crossesSegment from to = (to-from) .>. (to `rem` segment_size) + -- groupScan needs to treat the scan output as a one-dimensional + -- array of scan elements, so we invent some new flattened arrays + -- here. XXX: this assumes that the original index function is just + -- row-major, but does not actually verify it. + dims_flat <- dPrimV "dims_flat" $ product dims' + let flattened pe = do + MemLocation mem _ _ <- + entryArrayLocation <$> lookupArray (patElemName pe) + let pe_t = typeOf pe + arr_dims = Var dims_flat : drop (length dims') (arrayDims pe_t) + sArray (baseString (patElemName pe) ++ "_flat") + (elemType pe_t) (Shape arr_dims) $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) arr_dims + + num_scan_results = sum $ map (length . segBinOpNeutral) scans + + arrs_flat <- mapM flattened $ take num_scan_results $ patternElements pat + forM_ scans $ \scan -> do let scan_op = segBinOpLambda scan - groupScan (Just crossesSegment) (product dims') (product dims') scan_op $ - patternNames pat + groupScan (Just crossesSegment) (product dims') (product dims') scan_op arrs_flat compileGroupOp pat (Inner (SegOp (SegRed lvl space ops _ body))) = do compileGroupSpace lvl space @@ -688,7 +705,7 @@ chunk_var <-- Imp.BinOpExp (SMin Int32) (Imp.unCount elements_per_thread) - ((Imp.unCount num_elements - thread_index) `quotRoundingUp` stride') + ((Imp.unCount num_elements - thread_index) `divUp` stride') computeThreadChunkSize SplitContiguous thread_index elements_per_thread num_elements chunk_var = do starting_point <- dPrimV "starting_point" $ @@ -985,7 +1002,7 @@ barrier sComment "restore correct values for first block" $ - sWhen is_first_block $forM_ (zip3 x_params y_params arrs) $ \(x, y, arr) -> + sWhen is_first_block $ forM_ (zip3 x_params y_params arrs) $ \(x, y, arr) -> if primType (paramType y) then copyDWIM arr [DimFix ltid] (Var $ paramName y) [] else copyDWIM (paramName x) [] (Var arr) [DimFix $ arrs_full_size + group_offset + ltid] @@ -1087,7 +1104,7 @@ let group_size_var = Imp.var group_size int32 group_size_key = keyWithEntryPoint fname $ nameFromString $ pretty group_size sOp $ Imp.GetSize group_size group_size_key Imp.SizeGroup - num_groups <- dPrimV "num_groups" $ kernel_size `quotRoundingUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var + num_groups <- dPrimV "num_groups" $ kernel_size `divUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var return (Imp.var num_groups int32, Imp.var group_size int32) simpleKernelConstants :: Imp.Exp -> String @@ -1130,7 +1147,7 @@ constants <- kernelConstants <$> askEnv phys_group_id <- dPrim "phys_group_id" int32 sOp $ Imp.GetGroupId phys_group_id 0 - let iterations = (required_groups - Imp.vi32 phys_group_id) `quotRoundingUp` + let iterations = (required_groups - Imp.vi32 phys_group_id) `divUp` kernelNumGroups constants sFor "i" iterations $ \i -> do @@ -1185,7 +1202,7 @@ -> CallKernelGen () sKernel ops flatf name num_groups group_size v f = do (constants, set_constants) <- kernelInitialisationSimple num_groups group_size - let name' = nameFromString $ name ++ "_" ++ show (baseTag v) + name' <- nameForFun $ name ++ "_" ++ show (baseTag v) sKernelFailureTolerant False ops constants name' $ do set_constants dPrimV_ v $ flatf constants @@ -1241,30 +1258,16 @@ (constants, set_constants) <- simpleKernelConstants (product dims) "replicate" - let is' = unflattenIndex dims $ kernelGlobalThreadId constants - name = nameFromString $ "replicate_" ++ - show (baseTag $ kernelGlobalThreadIdVar constants) + fname <- askFunction + let name = keyWithEntryPoint fname $ nameFromString $ + "replicate_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) + is' = unflattenIndex dims $ kernelGlobalThreadId constants sKernelFailureTolerant True threadOperations constants name $ do set_constants sWhen (kernelThreadActive constants) $ copyDWIMFix arr is' se $ drop (length ds) is' -replicateFunction :: PrimType -> CallKernelGen Imp.Function -replicateFunction bt = do - mem <- newVName "mem" - num_elems <- newVName "num_elems" - val <- newVName "val" - - let params = [Imp.MemParam mem (Space "device"), - Imp.ScalarParam num_elems int32, - Imp.ScalarParam val bt] - shape = Shape [Var num_elems] - function [] params $ do - arr <- sArray "arr" bt shape $ ArrayIn mem $ IxFun.iota $ - map (primExpFromSubExp int32) $ shapeDims shape - sReplicateKernel arr $ Var val - replicateName :: PrimType -> String replicateName bt = "replicate_" ++ pretty bt @@ -1273,8 +1276,20 @@ let fname = nameFromString $ "builtin#" <> replicateName bt exists <- hasFunction fname - unless exists $ emitFunction fname =<< replicateFunction bt + unless exists $ do + mem <- newVName "mem" + num_elems <- newVName "num_elems" + val <- newVName "val" + let params = [Imp.MemParam mem (Space "device"), + Imp.ScalarParam num_elems int32, + Imp.ScalarParam val bt] + shape = Shape [Var num_elems] + function fname [] params $ do + arr <- sArray "arr" bt shape $ ArrayIn mem $ IxFun.iota $ + map (primExpFromSubExp int32) $ shapeDims shape + sReplicateKernel arr $ Var val + return fname replicateIsFill :: VName -> SubExp -> CallKernelGen (Maybe (CallKernelGen ())) @@ -1303,13 +1318,15 @@ Nothing -> sReplicateKernel arr se -- | Perform an Iota with a kernel. -sIota :: VName -> Imp.Exp -> Imp.Exp -> Imp.Exp -> IntType - -> CallKernelGen () -sIota arr n x s et = do +sIotaKernel :: VName -> Imp.Exp -> Imp.Exp -> Imp.Exp -> IntType + -> CallKernelGen () +sIotaKernel arr n x s et = do destloc <- entryArrayLocation <$> lookupArray arr (constants, set_constants) <- simpleKernelConstants n "iota" - let name = nameFromString $ "iota_" ++ + fname <- askFunction + let name = keyWithEntryPoint fname $ nameFromString $ + "iota_" ++ pretty et ++ "_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) sKernelFailureTolerant True threadOperations constants name $ do @@ -1322,6 +1339,47 @@ Imp.Write destmem destidx (IntType et) destspace Imp.Nonvolatile $ Imp.ConvOpExp (SExt Int32 et) gtid * s + x +iotaName :: IntType -> String +iotaName bt = "iota_" ++ pretty bt + +iotaForType :: IntType -> CallKernelGen Name +iotaForType bt = do + let fname = nameFromString $ "builtin#" <> iotaName bt + + exists <- hasFunction fname + unless exists $ do + mem <- newVName "mem" + n <- newVName "n" + x <- newVName "x" + s <- newVName "s" + + let params = [Imp.MemParam mem (Space "device"), + Imp.ScalarParam n int32, + Imp.ScalarParam x $ IntType bt, + Imp.ScalarParam s $ IntType bt] + shape = Shape [Var n] + n' = Imp.vi32 n + x' = Imp.var x $ IntType bt + s' = Imp.var s $ IntType bt + + function fname [] params $ do + arr <- sArray "arr" (IntType bt) shape $ ArrayIn mem $ IxFun.iota $ + map (primExpFromSubExp int32) $ shapeDims shape + sIotaKernel arr n' x' s' bt + + return fname + +-- | Perform an Iota with a kernel. +sIota :: VName -> Imp.Exp -> Imp.Exp -> Imp.Exp -> IntType + -> CallKernelGen () +sIota arr n x s et = do + ArrayEntry (MemLocation arr_mem _ arr_ixfun) _ <- lookupArray arr + if IxFun.isLinear arr_ixfun then do + fname <- iotaForType et + emit $ Imp.Call [] fname + [Imp.MemArg arr_mem, Imp.ExpArg n, Imp.ExpArg x, Imp.ExpArg s] + else sIotaKernel arr n x s et + sCopy :: CopyCompiler KernelsMem HostEnv Imp.HostOp sCopy bt destloc@(MemLocation destmem _ _) destslice @@ -1334,8 +1392,9 @@ (constants, set_constants) <- simpleKernelConstants kernel_size "copy" - let name = nameFromString $ "copy_" ++ - show (baseTag $ kernelGlobalThreadIdVar constants) + fname <- askFunction + let name = keyWithEntryPoint fname $ nameFromString $ + "copy_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) sKernelFailureTolerant True threadOperations constants name $ do set_constants @@ -1370,7 +1429,7 @@ then sWhen (offset + ltid .<. toExp' int32 w) $ copyDWIMFix (patElemName pe) [ltid + offset] (Var what) [ltid] else - sFor "i" (n `quotRoundingUp` kernelGroupSize constants) $ \i -> do + sFor "i" (n `divUp` kernelGroupSize constants) $ \i -> do j <- fmap Imp.vi32 $ dPrimV "j" $ kernelGroupSize constants * i + ltid sWhen (j .<. n) $ copyDWIMFix (patElemName pe) [j + offset] (Var what) [j] diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs @@ -55,8 +55,8 @@ import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Kernels.SegRed (compileSegRed') import Futhark.CodeGen.ImpGen.Kernels.Base -import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) -import Futhark.Util (chunks, mapAccumLM, splitFromEnd, takeLast) +import Futhark.Util.IntegralExp (divUp, quot, rem) +import Futhark.Util (chunks, mapAccumLM, maxinum, splitFromEnd, takeLast) import Futhark.Construct (fullSliceNum) i32Toi64 :: PrimExp v -> PrimExp v @@ -76,7 +76,7 @@ histoSpaceUsage :: HistOp KernelsMem -> Imp.Count Imp.Bytes Imp.Exp histoSpaceUsage op = - sum $ + fmap (ConvOpExp (SExt Int64 Int32)) $ sum $ map (typeSize . (`arrayOfRow` histWidth op) . (`arrayOfShape` histShape op)) $ @@ -237,7 +237,7 @@ hist_S <-- case passage of MayBeMultiPass -> - (hist_M_min * hist_H * hist_el_size) `quotRoundingUp` + (hist_M_min * hist_H * hist_el_size) `divUp` t64 (hist_F_L2 * r64 (Imp.vi32 hist_L2) * hist_RACE_exp) MustBeSinglePass -> 1 @@ -270,11 +270,11 @@ slugElSize (SegHistSlug op _ _ do_op) = case do_op of AtomicLocking{} -> - unCount - (sum $ map (typeSize . (`arrayOfShape` histShape op)) $ - Prim int32 : lambdaReturnType (histOp op)) + ConvOpExp (SExt Int64 Int32) $ unCount $ + sum $ map (typeSize . (`arrayOfShape` histShape op)) $ + Prim int32 : lambdaReturnType (histOp op) _ -> - unCount $ sum $ + ConvOpExp (SExt Int64 Int32) $ unCount $ sum $ map (typeSize . (`arrayOfShape` histShape op)) $ lambdaReturnType (histOp op) @@ -283,7 +283,7 @@ hist_H <- toExp $ histWidth op hist_H_chk <- dPrimVE "hist_H_chk" $ - hist_H `quotRoundingUp` hist_S + hist_H `divUp` hist_S emit $ Imp.DebugPrint "Chunk size (H_chk)" $ Just hist_H_chk @@ -360,7 +360,7 @@ hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w -> do w' <- toExp w - dPrimVE "hist_H_chk" $ w' `quotRoundingUp` hist_S + dPrimVE "hist_H_chk" $ w' `divUp` hist_S sKernelThread "seghist_global" num_groups group_size (segFlat space) $ do constants <- kernelConstants <$> askEnv @@ -369,7 +369,7 @@ subhisto_inds <- forM slugs $ \slug -> dPrimVE "subhisto_ind" $ kernelGlobalThreadId constants `quot` - (kernelNumThreads constants `quotRoundingUp` Imp.vi32 (slugNumSubhistos slug)) + (kernelNumThreads constants `divUp` Imp.vi32 (slugNumSubhistos slug)) -- Loop over flat offsets into the input and output. The -- calculation is done with 64-bit integers to avoid overflow, @@ -533,7 +533,7 @@ hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w -> do w' <- toExp w - dPrimV "hist_H_chk" $ w' `quotRoundingUp` hist_S + dPrimV "hist_H_chk" $ w' `divUp` hist_S sKernelThread "seghist_local" num_groups group_size (segFlat space) $ virtualiseGroups SegVirt (unCount groups_per_segment * num_segments) $ \group_id_var -> do @@ -577,7 +577,7 @@ onSlugs $ \slug dests hist_H_chk histo_dims histo_size -> do let group_hists_size = num_subhistos_per_group * histo_size init_per_thread <- dPrimVE "init_per_thread" $ - group_hists_size `quotRoundingUp` + group_hists_size `divUp` kernelGroupSize constants forM_ (zip dests (histNeutral $ slugOp slug)) $ @@ -658,7 +658,7 @@ sComment "Compact the multiple local memory subhistograms to result in global memory" $ onSlugs $ \slug dests hist_H_chk histo_dims histo_size -> do bins_per_thread <- dPrimVE "init_per_thread" $ - histo_size `quotRoundingUp` kernelGroupSize constants + histo_size `divUp` kernelGroupSize constants trunc_H <- dPrimV "trunc_H" $ Imp.BinOpExp (SMin Int32) hist_H_chk $ @@ -755,7 +755,7 @@ sOp $ Imp.GetSizeMax max_group_size Imp.SizeGroup let group_size = Imp.Count $ Var max_group_size num_groups <- fmap (Imp.Count . Var) $ dPrimV "num_groups" $ - hist_T `quotRoundingUp` toExp' int32 (unCount group_size) + hist_T `divUp` toExp' int32 (unCount group_size) let num_groups' = toExp' int32 <$> num_groups group_size' = toExp' int32 <$> group_size @@ -768,7 +768,7 @@ hist_m' <- dPrimVE "hist_m_prime" $ r64 (Imp.BinOpExp (SMin Int32) (Imp.vi32 hist_L `quot` hist_el_size) - (hist_N `quotRoundingUp` unCount num_groups')) + (hist_N `divUp` unCount num_groups')) / r64 hist_H let hist_B = unCount group_size' @@ -794,11 +794,11 @@ i64_to_i32 $ Imp.BinOpExp (SMin Int64) (i32_to_i64 hist_Nin * i32_to_i64 hist_Nout) (i32_to_i64 hist_T) - `quotRoundingUp` + `divUp` i32_to_i64 hist_Nout -- Number of groups, rounded up. - let r = hist_T_hist_min `quotRoundingUp` hist_B + let r = hist_T_hist_min `divUp` hist_B dPrimVE "work_asymp_M_max" $ hist_Nin `quot` (r * hist_H) @@ -818,7 +818,7 @@ -- "Cooperation factor" - the number of threads cooperatively -- working on the same (sub)histogram. hist_C <- dPrimVE "hist_C" $ - hist_B `quotRoundingUp` hist_M_nonzero + hist_B `divUp` hist_M_nonzero emit $ Imp.DebugPrint "local hist_M0" $ Just hist_M0 emit $ Imp.DebugPrint "local work asymp M max" $ Just work_asymp_M_max @@ -833,10 +833,10 @@ -- by doing multiple passes, although more than a few is -- (heuristically) not efficient. local_mem_needed <- dPrimVE "local_mem_needed" $ hist_el_size * Imp.vi32 hist_M - hist_S <- dPrimVE "hist_S" $ (hist_H * local_mem_needed) `quotRoundingUp` Imp.vi32 hist_L + hist_S <- dPrimVE "hist_S" $ (hist_H * local_mem_needed) `divUp` Imp.vi32 hist_L let max_S = case bodyPassage kbody of MustBeSinglePass -> 1 - MayBeMultiPass -> fromIntegral $ maximum $ map slugMaxLocalMemPasses slugs + MayBeMultiPass -> fromIntegral $ maxinum $ map slugMaxLocalMemPasses slugs -- We only use local memory if the number of updates per histogram -- at least matches the histogram size, as otherwise it is not @@ -850,7 +850,7 @@ .&&. Imp.vi32 hist_M .>. 0 groups_per_segment - | segmented = num_groups' `quotRoundingUp` Imp.Count hist_Nout + | segmented = num_groups' `divUp` Imp.Count hist_Nout | otherwise = num_groups' run = do @@ -906,7 +906,7 @@ let lockSize slug = case slugAtomicUpdate slug of AtomicLocking{} -> Just $ primByteSize int32 _ -> Nothing - hist_el_size <- dPrimVE "hist_el_size" $ foldl' (+) (h `quotRoundingUp` hist_H) $ + hist_el_size <- dPrimVE "hist_el_size" $ foldl' (+) (h `divUp` hist_H) $ mapMaybe lockSize slugs -- Input elements contributing to each histogram. diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +-- | Code generation for 'SegMap' is quite straightforward. The only +-- trick is virtualisation in case the physical number of threads is +-- not sufficient to cover the logical thread space. This is handled +-- by having actual workgroups run a loop to imitate multiple workgroups. module Futhark.CodeGen.ImpGen.Kernels.SegMap ( compileSegMap ) where @@ -12,7 +16,7 @@ import Futhark.CodeGen.ImpGen.Kernels.Base import Futhark.CodeGen.ImpGen import qualified Futhark.CodeGen.ImpCode.Kernels as Imp -import Futhark.Util.IntegralExp (quotRoundingUp) +import Futhark.Util.IntegralExp (divUp) -- | Compile 'SegMap' instance code. compileSegMap :: Pattern KernelsMem @@ -31,7 +35,7 @@ case lvl of SegThread{} -> do emit $ Imp.DebugPrint "\n# SegMap" Nothing - let virt_num_groups = product dims' `quotRoundingUp` unCount group_size' + let virt_num_groups = product dims' `divUp` unCount group_size' sKernelThread "segmap" num_groups' group_size' (segFlat space) $ virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do local_tid <- kernelLocalThreadId . kernelConstants <$> askEnv 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 @@ -11,7 +11,7 @@ -- -- * Instead of depending on storage layout transformations to handle -- non-commutative reductions efficiently, we slide a --- 'groupsize'-sized window over the input, and perform a parallel +-- @groupsize@-sized window over the input, and perform a parallel -- reduction for each window. This sacrifices the notion of -- efficient sequentialisation, but is sometimes faster and -- definitely simpler and more predictable (and uses less auxiliary @@ -62,13 +62,17 @@ import Futhark.CodeGen.ImpGen.Kernels.Base import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Util (chunks) -import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) +import Futhark.Util.IntegralExp (divUp, quot, rem) -- | The maximum number of operators we support in a single SegRed. -- This limit arises out of the static allocation of counters. maxNumOps :: Int32 maxNumOps = 10 +-- | 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. type DoSegBody = ([(SubExp, [Imp.Exp])] -> InKernelGen ()) -> InKernelGen () -- | Compile 'SegRed' instance to host-level code with calls to @@ -188,7 +192,7 @@ forM_ gtids $ \v -> dPrimV_ v 0 let num_elements = Imp.elements w - let elems_per_thread = num_elements `quotRoundingUp` Imp.elements (kernelNumThreads constants) + let elems_per_thread = num_elements `divUp` Imp.elements (kernelNumThreads constants) slugs <- mapM (segBinOpSlug (kernelLocalThreadId constants) @@ -233,7 +237,7 @@ let segment_size_nonzero = Imp.var segment_size_nonzero_v int32 num_segments = product $ init dims' segments_per_group = unCount group_size' `quot` segment_size_nonzero - required_groups = num_segments `quotRoundingUp` segments_per_group + required_groups = num_segments `divUp` segments_per_group emit $ Imp.DebugPrint "\n# SegRed-small" Nothing emit $ Imp.DebugPrint "num_segments" $ Just num_segments @@ -423,10 +427,10 @@ groupsPerSegmentAndElementsPerThread segment_size num_segments num_groups_hint group_size = do groups_per_segment <- dPrimVE "groups_per_segment" $ - unCount num_groups_hint `quotRoundingUp` BinOpExp (SMax Int32) 1 num_segments + unCount num_groups_hint `divUp` BinOpExp (SMax Int32) 1 num_segments elements_per_thread <- dPrimVE "elements_per_thread" $ - segment_size `quotRoundingUp` (unCount group_size * groups_per_segment) + segment_size `divUp` (unCount group_size * groups_per_segment) return (groups_per_segment, Imp.elements elements_per_thread) -- | A SegBinOp with auxiliary information. @@ -661,7 +665,7 @@ -- number of accesses should be tiny here. comment "read in the per-group-results" $ do read_per_thread <- dPrimVE "read_per_thread" $ - groups_per_segment `quotRoundingUp` group_size + groups_per_segment `divUp` group_size forM_ (zip red_x_params nes) $ \(p, ne) -> copyDWIMFix (paramName p) [] ne [] 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,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +-- | Code generation for segmented and non-segmented scans. Uses a +-- fairly inefficient two-pass algorithm. module Futhark.CodeGen.ImpGen.Kernels.SegScan ( compileSegScan ) where @@ -17,7 +19,7 @@ import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Kernels.Base import qualified Futhark.IR.Mem.IxFun as IxFun -import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) +import Futhark.Util.IntegralExp (divUp, quot, rem) import Futhark.Util (takeLast) -- Aggressively try to reuse memory for different SegBinOps, because @@ -140,7 +142,7 @@ let (gtids, dims) = unzip $ unSegSpace space dims' <- mapM toExp dims let num_elements = product dims' - elems_per_thread = num_elements `quotRoundingUp` Imp.vi32 num_threads + elems_per_thread = num_elements `divUp` Imp.vi32 num_threads elems_per_group = unCount group_size' * elems_per_thread let crossesSegment = @@ -333,7 +335,7 @@ let (gtids, dims) = unzip $ unSegSpace space dims' <- mapM toExp dims required_groups <- dPrimVE "required_groups" $ - product dims' `quotRoundingUp` unCount group_size' + product dims' `divUp` unCount group_size' sKernelThread "scan_stage3" num_groups' group_size' (segFlat space) $ virtualiseGroups SegVirt required_groups $ \virt_group_id -> do @@ -400,10 +402,22 @@ compileSegScan pat lvl space scans kbody = do emit $ Imp.DebugPrint "\n# SegScan" Nothing + -- Since stage 2 involves a group size equal to the number of groups + -- used for stage 1, we have to cap this number to the maximum group + -- size. + stage1_max_num_groups <- + dPrim "stage1_max_num_groups" int32 + sOp $ Imp.GetSizeMax stage1_max_num_groups SizeGroup + + stage1_num_groups <- + fmap (Imp.Count . Var) $ dPrimV "stage1_num_groups" $ + Imp.BinOpExp (SMin Int32) (Imp.vi32 stage1_max_num_groups) $ + toExp' int32 $ Imp.unCount $ segNumGroups lvl + (stage1_num_threads, elems_per_group, crossesSegment) <- - scanStage1 pat (segNumGroups lvl) (segGroupSize lvl) space scans kbody + scanStage1 pat stage1_num_groups (segGroupSize lvl) space scans kbody emit $ Imp.DebugPrint "elems_per_group" $ Just elems_per_group - scanStage2 pat stage1_num_threads elems_per_group (segNumGroups lvl) crossesSegment space scans + scanStage2 pat stage1_num_threads elems_per_group stage1_num_groups crossesSegment space scans scanStage3 pat (segNumGroups lvl) (segGroupSize lvl) elems_per_group crossesSegment space scans diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs @@ -9,9 +9,9 @@ ) where +import Control.Monad.Reader import Control.Monad.State import Control.Monad.Identity -import Control.Monad.Reader import Data.FileEmbed import Data.Maybe import qualified Data.Set as S @@ -21,12 +21,14 @@ import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Quote.CUDA as CUDAC -import qualified Futhark.CodeGen.Backends.GenericC as GenericC +import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.Kernels hiding (Program) import qualified Futhark.CodeGen.ImpCode.Kernels as ImpKernels import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) import qualified Futhark.CodeGen.ImpCode.OpenCL as ImpOpenCL +import Futhark.Error (compilerLimitationS) +import Futhark.IR.Prop (isBuiltInFunction) import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) import Futhark.Util.Pretty (prettyOneLine) @@ -40,23 +42,30 @@ -> ImpKernels.Program -> ImpOpenCL.Program translateKernels target prog = - let (prog', ToOpenCL kernels used_types sizes failures) = - flip runState initialOpenCL $ do + let (prog', + ToOpenCL kernels device_funs used_types sizes failures) = + + (`runState` initialOpenCL) . (`runReaderT` defFuns prog) $ do let ImpKernels.Definitions (ImpKernels.Constants ps consts) (ImpKernels.Functions funs) = prog - consts' <- runReaderT (traverse (onHostOp target) consts) - (nameFromString "val") + consts' <- traverse (onHostOp target) consts funs' <- forM funs $ \(fname, fun) -> - (fname,) <$> runReaderT (traverse (onHostOp target) fun) fname + (fname,) <$> traverse (onHostOp target) fun + return $ ImpOpenCL.Definitions (ImpOpenCL.Constants ps consts') (ImpOpenCL.Functions funs') + (device_prototypes, device_defs) = unzip $ M.elems device_funs kernels' = M.map fst kernels opencl_code = openClCode $ map snd $ M.elems kernels - opencl_prelude = pretty $ genPrelude target used_types + opencl_prelude = + unlines [pretty $ genPrelude target used_types, + unlines $ map pretty device_prototypes, + unlines $ map pretty device_defs] + in ImpOpenCL.Program opencl_code opencl_prelude kernels' (S.toList used_types) (cleanSizes sizes) failures prog' @@ -102,17 +111,23 @@ errorLabel :: KernelState -> String errorLabel = ("error_"++) . show . kernelNextSync -data ToOpenCL = ToOpenCL { clKernels :: M.Map KernelName (Safety, C.Func) +data ToOpenCL = ToOpenCL { clKernels :: M.Map KernelName (KernelSafety, C.Func) + , clDevFuns :: M.Map Name (C.Definition, C.Func) , clUsedTypes :: S.Set PrimType , clSizes :: M.Map Name SizeClass , clFailures :: [FailureMsg] } initialOpenCL :: ToOpenCL -initialOpenCL = ToOpenCL mempty mempty mempty mempty +initialOpenCL = ToOpenCL mempty mempty mempty mempty mempty -type OnKernelM = ReaderT Name (State ToOpenCL) +type AllFunctions = ImpKernels.Functions ImpKernels.HostOp +lookupFunction :: Name -> AllFunctions -> Maybe ImpKernels.Function +lookupFunction fname (ImpKernels.Functions fs) = lookup fname fs + +type OnKernelM = ReaderT AllFunctions (State ToOpenCL) + addSize :: Name -> SizeClass -> OnKernelM () addSize key sclass = modify $ \s -> s { clSizes = M.insert key sclass $ clSizes s } @@ -128,16 +143,82 @@ onHostOp _ (ImpKernels.GetSizeMax v size_class) = return $ ImpOpenCL.GetSizeMax v size_class +genGPUCode :: OpsMode -> KernelCode -> [FailureMsg] + -> GC.CompilerM KernelOp KernelState a + -> (a, GC.CompilerState KernelState) +genGPUCode mode body failures = + GC.runCompilerM (inKernelOperations mode body) + blankNameSource (newKernelState failures) + +-- Compilation of a device function that is not not invoked from the +-- host, but is invoked by (perhaps multiple) kernels. +generateDeviceFun :: Name -> ImpKernels.Function -> OnKernelM () +generateDeviceFun fname host_func = do + -- Functions are a priori always considered host-level, so we have + -- to convert them to device code. This is where most of our + -- limitations on device-side functions (no arrays, no parallelism) + -- comes from. + let device_func = fmap toDevice host_func + when (any memParam $ functionInput host_func) bad + + failures <- gets clFailures + + let params = + [[C.cparam|__global int *global_failure|], + [C.cparam|__global int *global_failure_args|]] + (func, cstate) = + genGPUCode FunMode (functionBody device_func) failures $ + GC.compileFun mempty params (fname, device_func) + kstate = GC.compUserState cstate + + modify $ \s -> s + { clUsedTypes = typesInCode (functionBody device_func) <> clUsedTypes s + , clDevFuns = M.insert fname func $ clDevFuns s + , clFailures = kernelFailures kstate + } + + -- Important to do this after the 'modify' call, so we propagate the + -- right clFailures. + void $ ensureDeviceFuns $ functionBody device_func + + where toDevice :: HostOp -> KernelOp + toDevice _ = bad + + memParam MemParam{} = True + memParam ScalarParam{} = False + + bad = compilerLimitationS "Cannot generate GPU functions that use arrays." + +-- Ensure that this device function is available, but don't regenerate +-- it if it already exists. +ensureDeviceFun :: Name -> ImpKernels.Function -> OnKernelM () +ensureDeviceFun fname host_func = do + exists <- gets $ M.member fname . clDevFuns + unless exists $ generateDeviceFun fname host_func + +ensureDeviceFuns :: ImpKernels.KernelCode -> OnKernelM [Name] +ensureDeviceFuns code = do + let called = calledFuncs code + fmap catMaybes $ forM (S.toList called) $ \fname -> do + def <- asks $ lookupFunction fname + case def of + Just func -> do ensureDeviceFun fname func + return $ Just fname + Nothing -> return Nothing + onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL onKernel target kernel = do + called <- ensureDeviceFuns $ kernelBody kernel + + -- Crucial that this is done after 'ensureDeviceFuns', as the device + -- functions may themselves define failure points. failures <- gets clFailures + let (kernel_body, cstate) = - GenericC.runCompilerM (inKernelOperations (kernelBody kernel)) - blankNameSource - (newKernelState failures) $ - GenericC.blockScope $ GenericC.compileCode $ kernelBody kernel - kstate = GenericC.compUserState cstate + genGPUCode KernelMode (kernelBody kernel) failures $ + GC.blockScope $ GC.compileCode $ kernelBody kernel + kstate = GC.compUserState cstate use_params = mapMaybe useAsParam $ kernelUses kernel @@ -170,6 +251,10 @@ (const_defs, const_undefs) = unzip $ mapMaybe constDef $ kernelUses kernel let (safety, error_init) + -- We conservatively assume that any called function can fail. + | not $ null called = + (SafetyFull, []) + | length (kernelFailures kstate) == length failures = if kernelFailureTolerant kernel then (SafetyNone, []) @@ -230,7 +315,7 @@ kernelArgs kernel return $ LaunchKernel safety name args num_groups group_size - where name = nameToString $ kernelName kernel + where name = kernelName kernel num_groups = kernelNumGroups kernel group_size = kernelGroupSize kernel @@ -250,7 +335,7 @@ let ctp = case bt of -- OpenCL does not permit bool as a kernel parameter type. Bool -> [C.cty|unsigned char|] - _ -> GenericC.primTypeToCType bt + _ -> GC.primTypeToCType bt in Just [C.cparam|$ty:ctp $id:name|] useAsParam (MemoryUse name) = Just [C.cparam|__global unsigned char *$id:name|] @@ -437,7 +522,7 @@ |] compilePrimExp :: PrimExp KernelConst -> C.Exp -compilePrimExp e = runIdentity $ GenericC.compilePrimExp compileKernelConst e +compilePrimExp e = runIdentity $ GC.compilePrimExp compileKernelConst e where compileKernelConst (SizeConst key) = return [C.cexp|$id:(zEncodeString (pretty key))|] @@ -447,17 +532,17 @@ useToArg (ScalarUse v bt) = Just $ ValueKArg (LeafExp (ScalarVar v) bt) bt useToArg ConstUse{} = Nothing -nextErrorLabel :: GenericC.CompilerM KernelOp KernelState String +nextErrorLabel :: GC.CompilerM KernelOp KernelState String nextErrorLabel = - errorLabel <$> GenericC.getUserState + errorLabel <$> GC.getUserState -incErrorLabel :: GenericC.CompilerM KernelOp KernelState () +incErrorLabel :: GC.CompilerM KernelOp KernelState () incErrorLabel = - GenericC.modifyUserState $ \s -> s { kernelNextSync = kernelNextSync s + 1 } + GC.modifyUserState $ \s -> s { kernelNextSync = kernelNextSync s + 1 } -pendingError :: Bool -> GenericC.CompilerM KernelOp KernelState () +pendingError :: Bool -> GC.CompilerM KernelOp KernelState () pendingError b = - GenericC.modifyUserState $ \s -> s { kernelSyncPending = b } + GC.modifyUserState $ \s -> s { kernelSyncPending = b } hasCommunication :: ImpKernels.KernelCode -> Bool hasCommunication = any communicates @@ -465,59 +550,66 @@ communicates Barrier{} = True communicates _ = False -inKernelOperations :: ImpKernels.KernelCode -> GenericC.Operations KernelOp KernelState -inKernelOperations body = - GenericC.Operations - { GenericC.opsCompiler = kernelOps - , GenericC.opsMemoryType = kernelMemoryType - , GenericC.opsWriteScalar = kernelWriteScalar - , GenericC.opsReadScalar = kernelReadScalar - , GenericC.opsAllocate = cannotAllocate - , GenericC.opsDeallocate = cannotDeallocate - , GenericC.opsCopy = copyInKernel - , GenericC.opsStaticArray = noStaticArrays - , GenericC.opsFatMemory = False - , GenericC.opsError = errorInKernel +-- Whether we are generating code for a kernel or a device function. +-- This has minor effects, such as exactly how failures are +-- propagated. +data OpsMode = KernelMode | FunMode deriving (Eq) + +inKernelOperations :: OpsMode -> ImpKernels.KernelCode + -> GC.Operations KernelOp KernelState +inKernelOperations mode body = + GC.Operations + { GC.opsCompiler = kernelOps + , GC.opsMemoryType = kernelMemoryType + , GC.opsWriteScalar = kernelWriteScalar + , GC.opsReadScalar = kernelReadScalar + , GC.opsAllocate = cannotAllocate + , GC.opsDeallocate = cannotDeallocate + , GC.opsCopy = copyInKernel + , GC.opsStaticArray = noStaticArrays + , GC.opsFatMemory = False + , GC.opsError = errorInKernel + , GC.opsCall = callInKernel } where has_communication = hasCommunication body fence FenceLocal = [C.cexp|CLK_LOCAL_MEM_FENCE|] fence FenceGlobal = [C.cexp|CLK_GLOBAL_MEM_FENCE | CLK_LOCAL_MEM_FENCE|] - kernelOps :: GenericC.OpCompiler KernelOp KernelState + kernelOps :: GC.OpCompiler KernelOp KernelState kernelOps (GetGroupId v i) = - GenericC.stm [C.cstm|$id:v = get_group_id($int:i);|] + GC.stm [C.cstm|$id:v = get_group_id($int:i);|] kernelOps (GetLocalId v i) = - GenericC.stm [C.cstm|$id:v = get_local_id($int:i);|] + GC.stm [C.cstm|$id:v = get_local_id($int:i);|] kernelOps (GetLocalSize v i) = - GenericC.stm [C.cstm|$id:v = get_local_size($int:i);|] + GC.stm [C.cstm|$id:v = get_local_size($int:i);|] kernelOps (GetGlobalId v i) = - GenericC.stm [C.cstm|$id:v = get_global_id($int:i);|] + GC.stm [C.cstm|$id:v = get_global_id($int:i);|] kernelOps (GetGlobalSize v i) = - GenericC.stm [C.cstm|$id:v = get_global_size($int:i);|] + GC.stm [C.cstm|$id:v = get_global_size($int:i);|] kernelOps (GetLockstepWidth v) = - GenericC.stm [C.cstm|$id:v = LOCKSTEP_WIDTH;|] + GC.stm [C.cstm|$id:v = LOCKSTEP_WIDTH;|] kernelOps (Barrier f) = do - GenericC.stm [C.cstm|barrier($exp:(fence f));|] - GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True } + GC.stm [C.cstm|barrier($exp:(fence f));|] + GC.modifyUserState $ \s -> s { kernelHasBarriers = True } kernelOps (MemFence FenceLocal) = - GenericC.stm [C.cstm|mem_fence_local();|] + GC.stm [C.cstm|mem_fence_local();|] kernelOps (MemFence FenceGlobal) = - GenericC.stm [C.cstm|mem_fence_global();|] + GC.stm [C.cstm|mem_fence_global();|] kernelOps (LocalAlloc name size) = do name' <- newVName $ pretty name ++ "_backing" - GenericC.modifyUserState $ \s -> + GC.modifyUserState $ \s -> s { kernelLocalMemory = (name', size) : kernelLocalMemory s } - GenericC.stm [C.cstm|$id:name = (__local char*) $id:name';|] + GC.stm [C.cstm|$id:name = (__local char*) $id:name';|] kernelOps (ErrorSync f) = do label <- nextErrorLabel - pending <- kernelSyncPending <$> GenericC.getUserState + pending <- kernelSyncPending <$> GC.getUserState when pending $ do pendingError False - GenericC.stm [C.cstm|$id:label: barrier($exp:(fence f));|] - GenericC.stm [C.cstm|if (local_failure) { return; }|] - GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|] -- intentional - GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True } + GC.stm [C.cstm|$id:label: barrier($exp:(fence f));|] + GC.stm [C.cstm|if (local_failure) { return; }|] + GC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|] -- intentional + GC.modifyUserState $ \s -> s { kernelHasBarriers = True } incErrorLabel kernelOps (Atomic space aop) = atomicOps space aop @@ -531,10 +623,10 @@ atomicSpace _ = "global" doAtomic s t old arr ind val op ty = do - ind' <- GenericC.compileExp $ unCount ind - val' <- GenericC.compileExp val + ind' <- GC.compileExp $ unCount ind + val' <- GC.compileExp val cast <- atomicCast s ty - GenericC.stm [C.cstm|$id:old = $id:op'(&(($ty:cast *)$id:arr)[$exp:ind'], ($ty:ty) $exp:val');|] + GC.stm [C.cstm|$id:old = $id:op'(&(($ty:cast *)$id:arr)[$exp:ind'], ($ty:ty) $exp:val');|] where op' = op ++ "_" ++ pretty t ++ "_" ++ atomicSpace s atomicOps s (AtomicAdd t old arr ind val) = @@ -565,33 +657,33 @@ doAtomic s t old arr ind val "atomic_xor" [C.cty|int|] atomicOps s (AtomicCmpXchg t old arr ind cmp val) = do - ind' <- GenericC.compileExp $ unCount ind - cmp' <- GenericC.compileExp cmp - val' <- GenericC.compileExp val + ind' <- GC.compileExp $ unCount ind + cmp' <- GC.compileExp cmp + val' <- GC.compileExp val cast <- atomicCast s [C.cty|int|] - GenericC.stm [C.cstm|$id:old = $id:op(&(($ty:cast *)$id:arr)[$exp:ind'], $exp:cmp', $exp:val');|] + GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast *)$id:arr)[$exp:ind'], $exp:cmp', $exp:val');|] where op = "atomic_cmpxchg_" ++ pretty t ++ "_" ++ atomicSpace s atomicOps s (AtomicXchg t old arr ind val) = do - ind' <- GenericC.compileExp $ unCount ind - val' <- GenericC.compileExp val + ind' <- GC.compileExp $ unCount ind + val' <- GC.compileExp val cast <- atomicCast s [C.cty|int|] - GenericC.stm [C.cstm|$id:old = $id:op(&(($ty:cast *)$id:arr)[$exp:ind'], $exp:val');|] + GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast *)$id:arr)[$exp:ind'], $exp:val');|] where op = "atomic_cmpxchg_" ++ pretty t ++ "_" ++ atomicSpace s - cannotAllocate :: GenericC.Allocate KernelOp KernelState + cannotAllocate :: GC.Allocate KernelOp KernelState cannotAllocate _ = error "Cannot allocate memory in kernel" - cannotDeallocate :: GenericC.Deallocate KernelOp KernelState + cannotDeallocate :: GC.Deallocate KernelOp KernelState cannotDeallocate _ _ = error "Cannot deallocate memory in kernel" - copyInKernel :: GenericC.Copy KernelOp KernelState + copyInKernel :: GC.Copy KernelOp KernelState copyInKernel _ _ _ _ _ _ _ = error "Cannot bulk copy in kernel." - noStaticArrays :: GenericC.StaticArray KernelOp KernelState + noStaticArrays :: GC.StaticArray KernelOp KernelState noStaticArrays _ _ _ _ = error "Cannot create static array in kernel." @@ -600,29 +692,48 @@ return [C.cty|$tyquals:quals $ty:defaultMemBlockType|] kernelWriteScalar = - GenericC.writeScalarPointerWithQuals pointerQuals + GC.writeScalarPointerWithQuals pointerQuals kernelReadScalar = - GenericC.readScalarPointerWithQuals pointerQuals + GC.readScalarPointerWithQuals pointerQuals + whatNext = do + label <- nextErrorLabel + pendingError True + return $ if has_communication + then [C.citems|local_failure = true; goto $id:label;|] + else if mode == FunMode + then [C.citems|return 1;|] + else [C.citems|return;|] + + callInKernel dests fname args + | isBuiltInFunction fname = + GC.opsCall GC.defaultOperations dests fname args + + | otherwise = do + let out_args = [ [C.cexp|&$id:d|] | d <- dests ] + args' = [C.cexp|global_failure|] : [C.cexp|global_failure_args|] : + out_args ++ args + + what_next <- whatNext + + GC.item [C.citem|if ($id:(funName fname)($args:args') != 0) { $items:what_next; }|] + errorInKernel msg@(ErrorMsg parts) backtrace = do - n <- length . kernelFailures <$> GenericC.getUserState - GenericC.modifyUserState $ \s -> + n <- length . kernelFailures <$> GC.getUserState + GC.modifyUserState $ \s -> s { kernelFailures = kernelFailures s ++ [FailureMsg msg backtrace] } let setArgs _ [] = return [] setArgs i (ErrorString{} : parts') = setArgs i parts' setArgs i (ErrorInt32 x : parts') = do - x' <- GenericC.compileExp x + x' <- GC.compileExp x stms <- setArgs (i+1) parts' return $ [C.cstm|global_failure_args[$int:i] = $exp:x';|] : stms argstms <- setArgs (0::Int) parts - label <- nextErrorLabel - pendingError True - let what_next - | has_communication = [C.citems|local_failure = true; - goto $id:label;|] - | otherwise = [C.citems|return;|] - GenericC.stm [C.cstm|{ if (atomic_cmpxchg_i32_global(global_failure, -1, $int:n) == -1) + + what_next <- whatNext + + GC.stm [C.cstm|{ if (atomic_cmpxchg_i32_global(global_failure, -1, $int:n) == -1) { $stms:argstms; } $items:what_next }|] diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs @@ -11,7 +11,7 @@ import Futhark.CodeGen.ImpCode.Kernels import Futhark.IR.Prop.Types -import Futhark.Util.IntegralExp (IntegralExp, quot, rem, quotRoundingUp) +import Futhark.Util.IntegralExp (IntegralExp, divUp, quot, rem) -- | Which form of transposition to generate code for. data TransposeType = TransposeNormal @@ -242,16 +242,16 @@ (num_groups, group_size) = case kind of TransposeSmall -> - ([(num_arrays * width * height) `quotRoundingUp` (block_dim * block_dim)], + ([(num_arrays * width * height) `divUp` (block_dim * block_dim)], [block_dim * block_dim]) TransposeLowWidth -> - lowDimKernelAndGroupSize block_dim num_arrays width $ height `quotRoundingUp` muly + lowDimKernelAndGroupSize block_dim num_arrays width $ height `divUp` muly TransposeLowHeight -> - lowDimKernelAndGroupSize block_dim num_arrays (width `quotRoundingUp` mulx) height + lowDimKernelAndGroupSize block_dim num_arrays (width `divUp` mulx) height TransposeNormal -> let actual_dim = block_dim*2 - in ( [ width `quotRoundingUp` actual_dim - , height `quotRoundingUp` actual_dim + in ( [ width `divUp` actual_dim + , height `divUp` actual_dim , num_arrays] , [actual_dim, actual_dim `quot` elemsPerThread, 1]) @@ -269,7 +269,7 @@ lowDimKernelAndGroupSize :: Exp -> Exp -> Exp -> Exp -> ([Exp], [Exp]) lowDimKernelAndGroupSize block_dim num_arrays x_elems y_elems = - ([x_elems `quotRoundingUp` block_dim, - y_elems `quotRoundingUp` block_dim, + ([x_elems `divUp` block_dim, + y_elems `divUp` block_dim, num_arrays], [block_dim, block_dim, 1]) 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,12 +1,15 @@ module Futhark.CodeGen.ImpGen.OpenCL ( compileProg + , Warnings ) where +import Data.Bifunctor (second) + import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL -import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels +import Futhark.CodeGen.ImpGen.Kernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog KernelsMem -> m OpenCL.Program -compileProg prog = kernelsToOpenCL <$> ImpGenKernels.compileProgOpenCL prog +compileProg :: MonadFreshNames m => Prog KernelsMem -> m (Warnings, OpenCL.Program) +compileProg prog = second kernelsToOpenCL <$> compileProgOpenCL prog diff --git a/src/Futhark/CodeGen/ImpGen/Sequential.hs b/src/Futhark/CodeGen/ImpGen/Sequential.hs --- a/src/Futhark/CodeGen/ImpGen/Sequential.hs +++ b/src/Futhark/CodeGen/ImpGen/Sequential.hs @@ -3,6 +3,7 @@ -- | Compile Futhark to sequential imperative code. module Futhark.CodeGen.ImpGen.Sequential ( compileProg + , ImpGen.Warnings ) where @@ -12,7 +13,7 @@ import Futhark.MonadFreshNames -- | Compile a 'SeqMem' program to sequential imperative code. -compileProg :: MonadFreshNames m => Prog SeqMem -> m Imp.Program +compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, Imp.Program) compileProg = ImpGen.compileProg () ops Imp.DefaultSpace where ops = ImpGen.defaultOperations opCompiler opCompiler dest (Alloc e space) = diff --git a/src/Futhark/CodeGen/OpenCL/Heuristics.hs b/src/Futhark/CodeGen/OpenCL/Heuristics.hs --- a/src/Futhark/CodeGen/OpenCL/Heuristics.hs +++ b/src/Futhark/CodeGen/OpenCL/Heuristics.hs @@ -13,19 +13,26 @@ ( SizeHeuristic (..) , DeviceType (..) , WhichSize (..) - , HeuristicValue (..) + , DeviceInfo (..) , sizeHeuristicsTable ) where +import Futhark.Analysis.PrimExp +import Futhark.Util.Pretty + -- | The type of OpenCL device that this heuristic applies to. data DeviceType = DeviceCPU | DeviceGPU --- | The value supplies by a heuristic can be a constant, or inferred --- from some device information. -data HeuristicValue = HeuristicConst Int - | HeuristicDeviceInfo String +-- | The value supplies by a heuristic can depend on some device +-- information. This will be translated into a call to +-- @clGetDeviceInfo()@. Make sure to only request info that can be +-- casted to a scalar type. +newtype DeviceInfo = DeviceInfo String +instance Pretty DeviceInfo where + ppr (DeviceInfo s) = text "device_info" <> parens (ppr s) + -- | A size that can be assigned a default. data WhichSize = LockstepWidth | NumGroups | GroupSize | TileSize | Threshold @@ -34,23 +41,29 @@ SizeHeuristic { platformName :: String , deviceType :: DeviceType , heuristicSize :: WhichSize - , heuristicValue :: HeuristicValue + , heuristicValue :: PrimExp DeviceInfo } -- | All of our heuristics. sizeHeuristicsTable :: [SizeHeuristic] sizeHeuristicsTable = - [ SizeHeuristic "NVIDIA CUDA" DeviceGPU LockstepWidth $ HeuristicConst 32 - , SizeHeuristic "AMD Accelerated Parallel Processing" DeviceGPU LockstepWidth $ HeuristicConst 32 - , SizeHeuristic "" DeviceGPU LockstepWidth $ HeuristicConst 1 - , SizeHeuristic "" DeviceGPU NumGroups $ HeuristicConst 256 - , SizeHeuristic "" DeviceGPU GroupSize $ HeuristicConst 256 - , SizeHeuristic "" DeviceGPU TileSize $ HeuristicConst 32 - , SizeHeuristic "" DeviceGPU Threshold $ HeuristicConst $ 32*1024 + [ SizeHeuristic "NVIDIA CUDA" DeviceGPU LockstepWidth $ constant 32 + , SizeHeuristic "AMD Accelerated Parallel Processing" DeviceGPU LockstepWidth $ constant 32 + , SizeHeuristic "" DeviceGPU LockstepWidth $ constant 1 + -- We calculate the number of groups to aim for 1024 threads per + -- compute unit if we also use the default group size. This seems + -- to perform well in practice. + , SizeHeuristic "" DeviceGPU NumGroups $ 4 * max_compute_units + , SizeHeuristic "" DeviceGPU GroupSize $ constant 256 + , SizeHeuristic "" DeviceGPU TileSize $ constant 32 + , SizeHeuristic "" DeviceGPU Threshold $ constant $ 32*1024 - , SizeHeuristic "" DeviceCPU LockstepWidth $ HeuristicConst 1 - , SizeHeuristic "" DeviceCPU NumGroups $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS" - , SizeHeuristic "" DeviceCPU GroupSize $ HeuristicConst 32 - , SizeHeuristic "" DeviceCPU TileSize $ HeuristicConst 4 - , SizeHeuristic "" DeviceCPU Threshold $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS" + , SizeHeuristic "" DeviceCPU LockstepWidth $ constant 1 + , SizeHeuristic "" DeviceCPU NumGroups max_compute_units + , SizeHeuristic "" DeviceCPU GroupSize $ constant 32 + , SizeHeuristic "" DeviceCPU TileSize $ constant 4 + , SizeHeuristic "" DeviceCPU Threshold max_compute_units ] + where constant = ValueExp . IntValue . Int32Value + max_compute_units = + LeafExp (DeviceInfo "MAX_COMPUTE_UNITS") $ IntType Int32 diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -11,6 +11,7 @@ , FutharkConfig (..) , newFutharkConfig , dumpError + , handleWarnings , module Futhark.Compiler.Program , readProgram @@ -112,12 +113,8 @@ runPipelineOnProgram config pipeline file = do when (pipelineVerbose pipeline_config) $ logMsg ("Reading and type-checking source program" :: String) - (ws, prog_imports, namesrc) <- readProgram file - - when (futharkWarn config) $ do - liftIO $ hPutStr stderr $ show ws - when (futharkWerror config && ws /= mempty) $ - externalErrorS "Treating above warnings as errors due to --Werror." + (prog_imports, namesrc) <- + handleWarnings config $ (\(a,b,c) -> (a,(b,c))) <$> readProgram file putNameSource namesrc when (pipelineVerbose pipeline_config) $ @@ -159,3 +156,18 @@ dumpError newFutharkConfig err exitWith $ ExitFailure 2 Right res' -> return res' + +-- | Run an operation that produces warnings, and handle them +-- appropriately, yielding the non-warning return value. "Proper +-- handling" means e.g. to print them to the screen, as directed by +-- the compiler configuration. +handleWarnings :: FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a +handleWarnings config m = do + (ws, a) <- m + + when (futharkWarn config) $ do + liftIO $ hPutStr stderr $ show ws + when (futharkWerror config && ws /= mempty) $ + externalErrorS "Treating above warnings as errors due to --Werror." + + return a 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 @@ -6,6 +6,8 @@ ( compilerMain , CompilerOption , CompilerMode(..) + , module Futhark.Pipeline + , module Futhark.Compiler ) where @@ -28,7 +30,8 @@ -> String -- ^ The short action name (e.g. "compile to C"). -> String -- ^ The longer action description. -> Pipeline SOACS lore -- ^ The pipeline to use. - -> (cfg -> CompilerMode -> FilePath -> Prog lore -> FutharkM ()) + -> (FutharkConfig -> cfg -> CompilerMode -> FilePath -> Prog lore + -> FutharkM ()) -- ^ The action to take on the result of the pipeline. -> String -- ^ Program name -> [String] -- ^ Command line arguments. @@ -37,7 +40,7 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 mainWithOptions (newCompilerConfig cfg) (commandLineOptions ++ map wrapOption cfg_opts) - "options... program" inspectNonOptions prog args + "options... " inspectNonOptions prog args where inspectNonOptions [file] config = Just $ compile config file inspectNonOptions _ _ = Nothing @@ -49,8 +52,10 @@ Action { actionName = name , actionDescription = desc , actionProcedure = - doIt (compilerConfig config) (compilerMode config) $ - outputFilePath filepath config + doIt (futharkConfig config) + (compilerConfig config) + (compilerMode config) + (outputFilePath filepath config) } -- | An option that modifies the configuration of type @cfg@. 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 @@ -20,7 +20,6 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Except -import qualified Data.Map.Strict as M import Data.Maybe import Data.List (intercalate) import qualified System.FilePath.Posix as Posix @@ -59,7 +58,7 @@ , basisNameSource = src , basisRoots = mempty } - where src = newNameSource $ succ $ maximum $ map E.baseTag $ M.keys E.intrinsics + where src = newNameSource $ E.maxIntrinsicTag + 1 readImport :: (MonadError CompilerError m, MonadIO m) => [ImportName] -> ImportName -> CompilerM m () diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -71,7 +71,6 @@ , eAssert , eBody , eLambda - , eDivRoundingUp , eRoundToMultipleOf , eSliceArray , eBlank @@ -267,18 +266,11 @@ bodyBind $ lambdaBody lam where bindParam param arg = letBindNames [paramName param] =<< arg --- | Note: unsigned division. -eDivRoundingUp :: MonadBinder m => - IntType -> m (Exp (Lore m)) -> m (Exp (Lore m)) -> m (Exp (Lore m)) -eDivRoundingUp t x y = - eBinOp (SQuot t) (eBinOp (Add t OverflowWrap) x (eBinOp (Sub t OverflowWrap) y (eSubExp one))) y - where one = intConst t 1 - eRoundToMultipleOf :: MonadBinder m => IntType -> m (Exp (Lore m)) -> m (Exp (Lore m)) -> m (Exp (Lore m)) eRoundToMultipleOf t x d = ePlus x (eMod (eMinus d (eMod x d)) d) - where eMod = eBinOp (SMod t) + where eMod = eBinOp (SMod t Unsafe) eMinus = eBinOp (Sub t OverflowWrap) ePlus = eBinOp (Add t OverflowWrap) diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -344,7 +344,7 @@ return $ specRow lhs (mhs <> " : ") rhs valBindHtml :: Html -> ValBind -> DocM (Html, Html, Html) -valBindHtml name (ValBind _ _ retdecl (Info (rettype, _)) tparams params _ _ _) = do +valBindHtml name (ValBind _ _ retdecl (Info (rettype, _)) tparams params _ _ _ _) = do let tparams' = mconcat $ map ((" "<>) . typeParamHtml) tparams noLink' = noLink $ map typeParamName tparams ++ map identName (S.toList $ mconcat $ map patternIdents params) diff --git a/src/Futhark/IR/Aliases.hs b/src/Futhark/IR/Aliases.hs --- a/src/Futhark/IR/Aliases.hs +++ b/src/Futhark/IR/Aliases.hs @@ -7,7 +7,7 @@ module Futhark.IR.Aliases ( -- * The Lore definition Aliases - , Names' (..) + , AliasDec (..) , VarAliases , ConsumedInExp , BodyAliasing @@ -57,40 +57,40 @@ -- | The lore for the basic representation. data Aliases lore --- | A wrapper around 'Names' to get around the fact that we need an --- 'Ord' instance, which 'Names' does not have. -newtype Names' = Names' { unNames :: Names } +-- | A wrapper around 'AliasDec to get around the fact that we need an +-- 'Ord' instance, which 'AliasDec does not have. +newtype AliasDec = AliasDec { unAliases :: Names } deriving (Show) -instance Semigroup Names' where - x <> y = Names' $ unNames x <> unNames y +instance Semigroup AliasDec where + x <> y = AliasDec $ unAliases x <> unAliases y -instance Monoid Names' where - mempty = Names' mempty +instance Monoid AliasDec where + mempty = AliasDec mempty -instance Eq Names' where +instance Eq AliasDec where _ == _ = True -instance Ord Names' where +instance Ord AliasDec where _ `compare` _ = EQ -instance Rename Names' where - rename (Names' names) = Names' <$> rename names +instance Rename AliasDec where + rename (AliasDec names) = AliasDec <$> rename names -instance Substitute Names' where - substituteNames substs (Names' names) = Names' $ substituteNames substs names +instance Substitute AliasDec where + substituteNames substs (AliasDec names) = AliasDec $ substituteNames substs names -instance FreeIn Names' where +instance FreeIn AliasDec where freeIn' = const mempty -instance PP.Pretty Names' where - ppr = PP.commasep . map PP.ppr . namesToList . unNames +instance PP.Pretty AliasDec where + ppr = PP.commasep . map PP.ppr . namesToList . unAliases -- | The aliases of the let-bound variable. -type VarAliases = Names' +type VarAliases = AliasDec -- | Everything consumed in the expression. -type ConsumedInExp = Names' +type ConsumedInExp = AliasDec -- | The aliases of what is returned by the t'Body', and what is -- consumed inside of it. @@ -108,9 +108,9 @@ type Op (Aliases lore) = OpWithAliases (Op lore) instance AliasesOf (VarAliases, dec) where - aliasesOf = unNames . fst + aliasesOf = unAliases . fst -instance FreeDec Names' where +instance FreeDec AliasDec where withoutAliases :: (HasScope (Aliases lore) m, Monad m) => ReaderT (Scope lore) m a -> m a @@ -123,13 +123,13 @@ withoutAliases . expTypesFromPattern . removePatternAliases instance (ASTLore lore, CanBeAliased (Op lore)) => Aliased (Aliases lore) where - bodyAliases = map unNames . fst . fst . bodyDec - consumedInBody = unNames . snd . fst . bodyDec + bodyAliases = map unAliases . fst . fst . bodyDec + consumedInBody = unAliases . snd . fst . bodyDec instance PrettyAnnot (PatElemT dec) => PrettyAnnot (PatElemT (VarAliases, dec)) where - ppAnnot (PatElem name (Names' als, dec)) = + ppAnnot (PatElem name (AliasDec als, dec)) = let alias_comment = PP.oneLine <$> aliasComment name als in case (alias_comment, ppAnnot (PatElem name dec)) of (_, Nothing) -> @@ -158,7 +158,7 @@ bodyAliases body _ -> Nothing - exp_dec = case namesToList $ unNames consumed of + exp_dec = case namesToList $ unAliases consumed of [] -> Nothing als -> Just $ PP.oneLine $ PP.text "-- Consumes " <> PP.commasep (map PP.ppr als) @@ -221,7 +221,7 @@ Lambda (Aliases lore) -> Lambda lore removeLambdaAliases = runIdentity . rephraseLambda removeAliases -removePatternAliases :: PatternT (Names', a) +removePatternAliases :: PatternT (AliasDec, a) -> PatternT a removePatternAliases = runIdentity . rephrasePattern (return . snd) @@ -251,7 +251,7 @@ in (zipWith annotateBindee (patternContextElements pat) context_als, zipWith annotateBindee (patternValueElements pat) als) where annotateBindee bindee names = - bindee `setPatElemLore` (Names' names', patElemDec bindee) + bindee `setPatElemLore` (AliasDec names', patElemDec bindee) where names' = case patElemType bindee of Array {} -> names @@ -292,7 +292,7 @@ foldMap (namesFromList . patternNames . stmPattern) bnds aliases' = map (`namesSubtract` boundNames) aliases consumed' = consumed `namesSubtract` boundNames - in (map Names' aliases', Names' consumed') + in (map AliasDec aliases', AliasDec consumed') mkStmsAliases :: Aliased lore => Stms lore -> [SubExp] @@ -335,13 +335,13 @@ -> Stm (Aliases lore) mkAliasedLetStm pat (StmAux cs attrs dec) e = Let (addAliasesToPattern pat e) - (StmAux cs attrs (Names' $ consumedInExp e, dec)) + (StmAux cs attrs (AliasDec $ consumedInExp e, dec)) e instance (Bindable lore, CanBeAliased (Op lore)) => Bindable (Aliases lore) where mkExpDec pat e = let dec = mkExpDec (removePatternAliases pat) $ removeExpAliases e - in (Names' $ consumedInExp e, dec) + in (AliasDec $ consumedInExp e, dec) mkExpPat ctx val e = addAliasesToPattern (mkExpPat ctx val $ removeExpAliases e) e diff --git a/src/Futhark/IR/Kernels/Kernel.hs b/src/Futhark/IR/Kernels/Kernel.hs --- a/src/Futhark/IR/Kernels/Kernel.hs +++ b/src/Futhark/IR/Kernels/Kernel.hs @@ -24,7 +24,6 @@ where import Futhark.IR -import qualified Futhark.Analysis.ScalExp as SE import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Util.Pretty as PP import Futhark.Util.Pretty @@ -33,12 +32,8 @@ import Futhark.Transform.Rename import Futhark.Optimise.Simplify.Lore import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.IR.Ranges - (Ranges) -import Futhark.IR.Prop.Ranges import Futhark.IR.Prop.Aliases -import Futhark.IR.Aliases - (Aliases) +import Futhark.IR.Aliases (Aliases) import Futhark.IR.SegOp import Futhark.IR.Kernels.Sizes import qualified Futhark.TypeCheck as TC @@ -172,12 +167,6 @@ opAliases _ = [mempty] consumedInOp _ = mempty -instance RangedOp SizeOp where - opRanges (SplitSpace _ _ _ elems_per_thread) = - [(Just (ScalarBound 0), - Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))] - opRanges _ = [unknownRange] - instance FreeIn SizeOp where freeIn' (SplitSpace o w i elems_per_thread) = freeIn' o <> freeIn' [w, i, elems_per_thread] @@ -268,11 +257,6 @@ consumedInOp (OtherOp op) = consumedInOp op consumedInOp (SizeOp op) = consumedInOp op -instance (ASTLore lore, RangedOp op) => RangedOp (HostOp lore op) where - opRanges (SegOp op) = opRanges op - opRanges (OtherOp op) = opRanges op - opRanges (SizeOp op) = opRanges op - instance (ASTLore lore, FreeIn op) => FreeIn (HostOp lore op) where freeIn' (SegOp op) = freeIn' op freeIn' (OtherOp op) = freeIn' op @@ -288,17 +272,6 @@ removeOpAliases (SegOp op) = SegOp $ removeOpAliases op removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op removeOpAliases (SizeOp op) = SizeOp op - -instance (CanBeRanged (Op lore), CanBeRanged op, ASTLore lore) => CanBeRanged (HostOp lore op) where - type OpWithRanges (HostOp lore op) = HostOp (Ranges lore) (OpWithRanges op) - - addOpRanges (SegOp op) = SegOp $ addOpRanges op - addOpRanges (OtherOp op) = OtherOp $ addOpRanges op - addOpRanges (SizeOp op) = SizeOp op - - removeOpRanges (SegOp op) = SegOp $ removeOpRanges op - removeOpRanges (OtherOp op) = OtherOp $ removeOpRanges op - removeOpRanges (SizeOp op) = SizeOp op instance (CanBeWise (Op lore), CanBeWise op, ASTLore lore) => CanBeWise (HostOp lore op) where type OpWithWisdom (HostOp lore op) = HostOp (Wise lore) (OpWithWisdom op) diff --git a/src/Futhark/IR/Kernels/Simplify.hs b/src/Futhark/IR/Kernels/Simplify.hs --- a/src/Futhark/IR/Kernels/Simplify.hs +++ b/src/Futhark/IR/Kernels/Simplify.hs @@ -22,21 +22,21 @@ import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Pass -import Futhark.IR.SOACS.Simplify (simplifySOAC) +import qualified Futhark.IR.SOACS.Simplify as SOAC import qualified Futhark.Optimise.Simplify as Simplify import Futhark.Optimise.Simplify.Rule import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Transform.FirstOrderTransform as FOT simpleKernels :: Simplify.SimpleOps Kernels -simpleKernels = Simplify.bindableSimpleOps $ simplifyKernelOp simplifySOAC +simpleKernels = Simplify.bindableSimpleOps $ simplifyKernelOp SOAC.simplifySOAC simplifyKernels :: Prog Kernels -> PassM (Prog Kernels) simplifyKernels = Simplify.simplifyProg simpleKernels kernelRules Simplify.noExtraHoistBlockers simplifyLambda :: (HasScope Kernels m, MonadFreshNames m) => - Lambda Kernels -> [Maybe VName] -> m (Lambda Kernels) + Lambda Kernels -> m (Lambda Kernels) simplifyLambda = Simplify.simplifyLambda simpleKernels kernelRules Engine.noExtraHoistBlockers @@ -78,11 +78,19 @@ asSegOp _ = Nothing segOp = SegOp +instance SOAC.HasSOAC (Wise Kernels) where + asSOAC (OtherOp soac) = Just soac + asSOAC _ = Nothing + soacOp = OtherOp + kernelRules :: RuleBook (Wise Kernels) kernelRules = standardRules <> segOpRules <> ruleBook - [ RuleOp redomapIotaToLoop ] - [ RuleBasicOp removeUnnecessaryCopy ] + [ RuleOp redomapIotaToLoop + , RuleOp SOAC.simplifyKnownIterationSOAC + , RuleOp SOAC.removeReplicateMapping ] + [ RuleBasicOp removeUnnecessaryCopy + , RuleOp SOAC.liftIdentityMapping ] -- We turn reductions over (solely) iotas into do-loops, because there -- is no useful structure here anyway. This is mostly a hack to work diff --git a/src/Futhark/IR/KernelsMem.hs b/src/Futhark/IR/KernelsMem.hs --- a/src/Futhark/IR/KernelsMem.hs +++ b/src/Futhark/IR/KernelsMem.hs @@ -18,6 +18,7 @@ where import Futhark.Analysis.PrimExp.Convert +import qualified Futhark.Analysis.UsageTable as UT import Futhark.MonadFreshNames import Futhark.Pass import Futhark.IR.Syntax @@ -69,6 +70,7 @@ matchPattern = matchPatternToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType + matchLoopResult = matchLoopResultMem instance BinderOps KernelsMem where mkExpDecB _ _ = return () @@ -81,16 +83,28 @@ mkLetNamesB = mkLetNamesB'' simplifyProg :: Prog KernelsMem -> PassM (Prog KernelsMem) -simplifyProg = - simplifyProgGeneric $ simplifyKernelOp $ const $ return ((), mempty) +simplifyProg = simplifyProgGeneric simpleKernelsMem simplifyStms :: (HasScope KernelsMem m, MonadFreshNames m) => Stms KernelsMem -> m (Engine.SymbolTable (Engine.Wise KernelsMem), Stms KernelsMem) -simplifyStms = - simplifyStmsGeneric $ simplifyKernelOp $ const $ return ((), mempty) +simplifyStms = simplifyStmsGeneric simpleKernelsMem simpleKernelsMem :: Engine.SimpleOps KernelsMem simpleKernelsMem = - simpleGeneric $ simplifyKernelOp $ const $ return ((), mempty) + simpleGeneric usage $ simplifyKernelOp $ const $ return ((), mempty) + where + -- Slightly hackily, we look at the inside of SegGroup operations + -- to figure out the sizes of local memory allocations, and add + -- usages for those sizes. This is necessary so the simplifier + -- will hoist those sizes out as far as possible (most + -- importantly, past the versioning If). + usage (SegOp (SegMap SegGroup{} _ _ kbody)) = localAllocs kbody + usage _ = mempty + localAllocs = foldMap stmLocalAlloc . kernelBodyStms + stmLocalAlloc = expLocalAlloc . stmExp + expLocalAlloc (Op (Alloc (Var v) (Space "local"))) = + UT.sizeUsage v + expLocalAlloc _ = + mempty 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 @@ -89,6 +89,7 @@ , matchBranchReturnType , matchPatternToExp , matchFunctionReturnType + , matchLoopResultMem , bodyReturnsFromPattern , checkMemInfo @@ -107,7 +108,7 @@ import Control.Monad.Except import qualified Data.Map.Strict as M import Data.Foldable (traverse_, toList) -import Data.List (find) +import Data.List (elemIndex, find) import qualified Data.Set as S import Futhark.Analysis.Metrics @@ -128,7 +129,6 @@ import Futhark.Optimise.Simplify.Lore import Futhark.IR.Aliases (Aliases, removeScopeAliases, removeExpAliases, removePatternAliases) -import Futhark.IR.Prop.Ranges import qualified Futhark.Analysis.SymbolTable as ST type LetDecMem = MemInfo SubExp NoUniqueness MemBind @@ -191,20 +191,6 @@ addOpAliases (Alloc se space) = Alloc se space addOpAliases (Inner k) = Inner $ addOpAliases k -instance RangedOp inner => RangedOp (MemOp inner) where - opRanges (Alloc _ _) = - [unknownRange] - opRanges (Inner k) = - opRanges k - -instance CanBeRanged inner => CanBeRanged (MemOp inner) where - type OpWithRanges (MemOp inner) = MemOp (OpWithRanges inner) - removeOpRanges (Alloc size space) = Alloc size space - removeOpRanges (Inner k) = Inner $ removeOpRanges k - - addOpRanges (Alloc size space) = Alloc size space - addOpRanges (Inner k) = Inner $ addOpRanges k - instance Rename inner => Rename (MemOp inner) where rename (Alloc size space) = Alloc <$> rename size <*> pure space rename (Inner k) = Inner <$> rename k @@ -368,7 +354,7 @@ instance PP.Pretty MemBind where ppr (ArrayIn mem ixfun) = - PP.text "@" <> PP.ppr mem <> PP.text "->" <> PP.ppr ixfun + PP.text "@" <> PP.ppr mem <> PP.text "->" PP. PP.ppr ixfun instance FreeIn MemBind where freeIn' (ArrayIn mem ixfun) = freeIn' mem <> freeIn' ixfun @@ -426,13 +412,13 @@ instance PP.Pretty MemReturn where ppr (ReturnsInBlock v ixfun) = - PP.parens $ PP.text (pretty v) <> PP.text "->" <> PP.ppr ixfun + PP.parens $ PP.text (pretty v) <> PP.text "->" PP. PP.ppr ixfun ppr (ReturnsNewBlock space i ixfun) = - PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" <> PP.ppr ixfun + PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" PP. PP.ppr ixfun instance FreeIn MemReturn where freeIn' (ReturnsInBlock v ixfun) = freeIn' v <> freeIn' ixfun - freeIn' _ = mempty + freeIn' (ReturnsNewBlock space _ ixfun) = freeIn' space <> freeIn' ixfun instance Engine.Simplifiable MemReturn where simplify (ReturnsNewBlock space i ixfun) = @@ -492,12 +478,17 @@ bodyReturnsToExpReturns :: BodyReturns -> ExpReturns bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns -matchFunctionReturnType :: Mem lore => - [FunReturns] -> Result -> TC.TypeM lore () -matchFunctionReturnType rettype result = do +matchRetTypeToResult :: Mem lore => + [FunReturns] -> Result -> TC.TypeM lore () +matchRetTypeToResult rettype result = do scope <- askScope result_ts <- runReaderT (mapM subExpMemInfo result) $ removeScopeAliases scope matchReturnType rettype result result_ts + +matchFunctionReturnType :: Mem lore => + [FunReturns] -> Result -> TC.TypeM lore () +matchFunctionReturnType rettype result = do + matchRetTypeToResult rettype result mapM_ checkResultSubExp result where checkResultSubExp Constant{} = return () @@ -515,6 +506,36 @@ " returned by function, but has nontrivial index function " ++ pretty ixfun +matchLoopResultMem :: Mem lore => + [FParam (Aliases lore)] -> [FParam (Aliases lore)] + -> [SubExp] -> TC.TypeM lore () +matchLoopResultMem ctx val = matchRetTypeToResult rettype + where ctx_names = map paramName ctx + + -- Invent a ReturnType so we can pretend that the loop body is + -- actually returning from a function. + rettype = map (toRet . paramDec) val + + toExtV v + | Just i <- v `elemIndex` ctx_names = Ext i + | otherwise = Free v + + toExtSE (Var v) = Var <$> toExtV v + toExtSE (Constant v) = Free $ Constant v + + toRet (MemPrim t) = + MemPrim t + toRet (MemMem space) = + MemMem space + toRet (MemArray pt shape u (ArrayIn mem ixfun)) + | Just i <- mem `elemIndex` ctx_names, + Param _ (MemMem space) : _ <- drop i ctx = + MemArray pt shape' u $ ReturnsNewBlock space i ixfun' + | otherwise = + MemArray pt shape' u $ ReturnsInBlock mem ixfun' + where shape' = fmap toExtSE shape + ixfun' = existentialiseIxFun ctx_names ixfun + matchBranchReturnType :: Mem lore => [BodyReturns] -> Body (Aliases lore) @@ -602,10 +623,7 @@ "\nixfun of return type: ", pretty x_ixfun, "\nand context elements: ", pretty ctx_res] case x_mem_type of - MemMem y_space -> do - unless (x_mem == Var y_mem) $ - throwError $ unwords ["Expected memory", pretty x_ext, "=>", pretty x_mem, - "but got", pretty y_mem] + MemMem y_space -> unless (x_space == y_space) $ throwError $ unwords ["Expected memory", pretty y_mem, "in space", pretty x_space, "but actually in space", pretty y_space] @@ -617,13 +635,12 @@ "but array returned in", pretty y] bad :: String -> TC.TypeM lore a - bad s = TC.bad $ TC.TypeError $ - unlines [ "Return type" - , " " ++ prettyTuple rettype - , "cannot match returns of results" - , " " ++ prettyTuple ts - , s - ] + bad s = TC.bad $ TC.TypeError $ PP.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 unless (length (S.unions $ map extsInMemInfo rettype) == length ctx_res) $ TC.bad $ TC.TypeError $ "Too many context parameters for the number of " ++ @@ -662,20 +679,20 @@ matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) = x_pt == y_pt && x_shape == y_shape && case (x_ret, y_ret) of - (ReturnsInBlock x_mem x_ixfun, Just (ReturnsInBlock y_mem y_ixfun)) -> + (ReturnsInBlock _ x_ixfun, Just (ReturnsInBlock _ y_ixfun)) -> let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_mem == y_mem && x_ixfun' == y_ixfun' + in IxFun.closeEnough x_ixfun' y_ixfun' (ReturnsInBlock _ x_ixfun, Just (ReturnsNewBlock _ _ y_ixfun)) -> let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_ixfun' == y_ixfun' - (ReturnsNewBlock x_space x_i x_ixfun, - Just (ReturnsNewBlock y_space y_i y_ixfun)) -> + in IxFun.closeEnough x_ixfun' y_ixfun' + (ReturnsNewBlock _ x_i x_ixfun, + Just (ReturnsNewBlock _ y_i y_ixfun)) -> let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_space == y_space && x_i == y_i && IxFun.closeEnough x_ixfun' y_ixfun' + in x_i == y_i && IxFun.closeEnough x_ixfun' y_ixfun' (_, Nothing) -> True _ -> False matches _ _ _ _ = False @@ -801,10 +818,8 @@ case bindeeLore bindee of dec@MemArray{} -> Just $ - PP.text "-- " <> - PP.oneLine (PP.ppr (bindeeName bindee) <> - PP.text " : " <> - PP.ppr dec) + PP.stack $ map (("-- "<>) . PP.text) $ lines $ + pretty (PP.ppr (bindeeName bindee) PP.<+> ":" PP.<+> PP.ppr dec) MemMem {} -> Nothing MemPrim _ -> @@ -863,15 +878,6 @@ expReturns (BasicOp (Opaque (Var v))) = pure <$> varReturns v - -expReturns (BasicOp (Repeat outer_shapes inner_shape v)) = do - t <- repeatDims outer_shapes inner_shape <$> lookupType v - (et, _, mem, ixfun) <- arrayVarReturns v - let outer_shapes' = map (map (primExpFromSubExp int32) . shapeDims) outer_shapes - inner_shape' = map (primExpFromSubExp int32) $ shapeDims inner_shape - return [MemArray et (Shape $ map Free $ arrayDims t) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ - IxFun.repeat ixfun outer_shapes' inner_shape'] expReturns (BasicOp (Reshape newshape v)) = do (et, _, mem, ixfun) <- arrayVarReturns v 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 @@ -5,13 +5,11 @@ ( IxFun(..) , index , iota - , offsetIndex , permute , rotate , reshape , slice , rebase - , repeat , shape , rank , linearWithOffset @@ -20,21 +18,23 @@ , isLinear , substituteInIxFun , leastGeneralGeneralization + , existentialize , closeEnough ) where -import Prelude hiding (mod, repeat) +import Prelude hiding (mod) import Data.List (sort, sortBy, zip4, zip5, zipWith5) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import Data.Function (on) import Data.Maybe (isJust) import Control.Monad.Identity +import Control.Monad.State import Control.Monad.Writer import qualified Data.Map.Strict as M -import Futhark.Analysis.PrimExp (PrimExp(..)) +import Futhark.Analysis.PrimExp (PrimExp(..), primExpType) import Futhark.IR.Syntax.Core (Ext(..)) import Futhark.Transform.Substitute import Futhark.Transform.Rename @@ -68,9 +68,9 @@ -- permutation can be performed directly on LMAD dimensions, but then it is -- difficult to extract the permutation back from an LMAD. -- --- LMAD algebra is closed under composition w.r.t. operators such as permute, --- repeat, index and slice. However, other operations, such as reshape, cannot --- always be represented inside the LMAD algebra. +-- LMAD algebra is closed under composition w.r.t. operators such as +-- permute, index and slice. However, other operations, such as +-- reshape, cannot always be represented inside the LMAD algebra. -- -- It follows that the general representation of an index function is a list of -- LMADS, in which each following LMAD in the list implicitly corresponds to an @@ -286,27 +286,6 @@ perm = map (perm_cur !!) perm_new in IxFun (setLMADPermutation perm lmad :| lmads) oshp cg --- | Repeat dimensions. -repeat :: (Eq num, IntegralExp num) => - IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat (IxFun (lmad@(LMAD off dims) :| lmads) oshp _) shps shp = - let perm = lmadPermutation lmad - -- inverse permute the shapes and update the permutation - lens = map (\s -> 1 + length s) shps - (shps', lens') = unzip $ permuteInv perm $ zip shps lens - scn = drop 1 $ scanl (+) 0 lens' - perm' = concatMap (\(p, l) -> map (\i-> (scn !! p) - l + i) [0..l-1]) - $ zip perm lens - tmp = length perm' - perm'' = perm' ++ [tmp..tmp-1+length shp] - - dims' = concatMap (\(shp_k, srnp) -> - map fakeDim shp_k ++ [srnp] - ) $ zip shps' dims - lmad' = setLMADPermutation perm'' $ LMAD off (dims' ++ map fakeDim shp) - in IxFun (lmad' :| lmads) oshp False -- XXX: Can we be less conservative? - where fakeDim x = LMADDim 0 0 x 0 Unknown - -- | Rotate an index function. rotate :: (Eq num, IntegralExp num) => IxFun num -> Indices num -> IxFun num @@ -514,7 +493,7 @@ (False, False, _) -> ( (ip, (0, newDim shpdim)) : sup, rpt ) -- already checked that the reshaped - -- dims cannot be repeats or rotates + -- dims cannot be rotates _ -> error "reshape: reached impossible case" ) ([], []) $ reverse $ zip3 iota_shape newshape perm' @@ -587,8 +566,7 @@ rebaseNice new_base@(IxFun (lmad_base :| lmads_base) _ cg_base) ixfun@(IxFun lmads shp cg) = do - let (lmad_full :| lmads') = NE.reverse lmads - ((outer_shapes, inner_shape), lmad) = shaveoffRepeats lmad_full + let (lmad :| lmads') = NE.reverse lmads dims = lmadDims lmad perm = lmadPermutation lmad perm_base = lmadPermutation lmad_base @@ -643,40 +621,9 @@ (LMAD (off_base + ldStride (last dims_base) * lmadOffset lmad) dims_base') new_base' = IxFun (lmad_base'' :| lmads_base) shp cg_base - IxFun lmads_base' _ _ = if all null outer_shapes && null inner_shape - then new_base' - else repeat new_base' outer_shapes inner_shape + IxFun lmads_base' _ _ = new_base' lmads'' = lmads' ++@ lmads_base' return $ IxFun lmads'' shp (cg && cg_base) - where shaveoffRepeats :: (Eq num, IntegralExp num) => - LMAD num -> (([Shape num], Shape num), LMAD num) - shaveoffRepeats lmad = - -- Given an input lmad, this function computes a repetition @r@ and a new lmad - -- @res@, such that @repeat r res@ is identical to the input lmad. - let perm = lmadPermutation lmad - dims = lmadDims lmad - -- compute the Repeat: - resacc= foldl (\acc (LMADDim s _ n _ _) -> - case acc of - rpt : acc0 -> - if s == 0 then (n : rpt) : acc0 - else [] : (rpt : acc0) - _ -> error "shaveoffRepeats: empty accumulator" - ) [[]] $ reverse $ permuteFwd perm dims - last_shape = last resacc - shapes = take (length resacc - 1) resacc - -- update permutation and lmad: - howManyRepLT k = - foldl (\i (LMADDim s _ _ p _) -> - if s == 0 && p < k then i + 1 else i - ) 0 dims - dims' = foldl (\acc (LMADDim s r n p info) -> - if s == 0 then acc - else let p' = p - howManyRepLT p - in LMADDim s r n p' info : acc - ) [] $ reverse dims - lmad' = LMAD (lmadOffset lmad) dims' - in ((shapes, last_shape), lmad') -- | Rebase an index function on top of a new base. rebase :: (Eq num, IntegralExp num) => @@ -696,16 +643,6 @@ ixfunMonotonicity :: (Eq num, IntegralExp num) => IxFun num -> Monotonicity ixfunMonotonicity = ixfunMonotonicityRots False --- | Offset index. Results in the index function corresponding to indexing with --- @i@ on the outermost dimension. -offsetIndex :: (Eq num, IntegralExp num) => - IxFun num -> num -> IxFun num -offsetIndex ixfun i | i == 0 = ixfun -offsetIndex ixfun i = - case shape ixfun of - d : ds -> slice ixfun (DimSlice i (d - i) 1 : map (unitSlice 0) ds) - [] -> error "offsetIndex: underlying index function has rank zero" - -- | If the memory support of the index function is contiguous and row-major -- (i.e., no transpositions, repetitions, rotates, etc.), then this should -- return the offset from which the memory-support of this index function @@ -809,7 +746,7 @@ (oshp, m2) <- generalize m1 oshp1 oshp2 (dstd, m3) <- generalize m2 (lmadDSrd lmad1) (lmadDSrd lmad2) (drot, m4) <- generalize m3 (lmadDRot lmad1) (lmadDRot lmad2) - (offt, m5) <- PEG.leastGeneralGeneralization m4 (lmadOffset lmad1) (lmadOffset lmad2) + let (offt, m5) = PEG.leastGeneralGeneralization m4 (lmadOffset lmad1) (lmadOffset lmad2) let lmad_dims = map (\(a,b,c,d,e) -> LMADDim a b c d e) $ zip5 dstd drot dshp dperm dmon lmad = LMAD offt lmad_dims @@ -820,11 +757,54 @@ lmadDRot = map ldRotate . lmadDims generalize m l1 l2 = foldM (\(l_acc, m') (pe1,pe2) -> do - (e, m'') <- PEG.leastGeneralGeneralization m' pe1 pe2 + let (e, m'') = PEG.leastGeneralGeneralization m' pe1 pe2 return (l_acc++[e], m'') ) ([], m) (zip l1 l2) leastGeneralGeneralization _ _ = Nothing +isSequential :: [Int] -> Bool +isSequential xs = + all (uncurry (==)) $ zip xs [0..] + +existentializeExp :: PrimExp v -> State [PrimExp v] (PrimExp (Ext v)) +existentializeExp e = do + i <- gets length + modify (++ [e]) + let t = primExpType e + return $ LeafExp (Ext i) t + +-- We require that there's only one lmad, and that the index function is contiguous, and the base shape has only one dimension +existentialize :: (Eq v, Pretty v) => + IxFun (PrimExp v) -> State [PrimExp v] (Maybe (IxFun (PrimExp (Ext v)))) +existentialize (IxFun (lmad :| []) oshp True) + | all ((== 0) . ldRotate) (lmadDims lmad), + length (lmadShape lmad) == length oshp, + isSequential (map ldPerm $ lmadDims lmad) = do + oshp' <- mapM existentializeExp oshp + lmadOffset' <- existentializeExp $ lmadOffset lmad + lmadDims' <- mapM existentializeLMADDim $ lmadDims lmad + let lmad' = LMAD lmadOffset' lmadDims' + return $ Just $ IxFun (lmad' :| []) oshp' True + where + existentializeLMADDim :: LMADDim (PrimExp v) -> State [PrimExp v] (LMADDim (PrimExp (Ext v))) + existentializeLMADDim (LMADDim str rot shp perm mon) = do + stride' <- existentializeExp str + shape' <- existentializeExp shp + return $ LMADDim stride' (fmap Free rot) shape' perm mon + + -- oshp' = LeafExp (Ext 0) + -- lmad' = LMAD lmadOffset' lmadDims' + -- lmadOffset' = LeafExp (Ext 1) + -- (_, lmadDims', lmadDimSubsts) = foldr generalizeDim (2, [], []) $ lmadDims lmad + -- substs = oshp : lmadOffset lmad' : lmadDimSubsts + + -- generalizeDim :: (Int, [LMADDim num]) -> LMADDim num -> (Int, [LMADDim num]) + -- generalizeDim (i, acc) (LMADDim stride rotate shape perm mon) = + -- (i + 3, + -- LMADDim (LeafExp $ Ext i) (LeafExp $ Ext $ i + 1) (LeafExp $ Ext $ i + 2) perm mon, + -- [stride, rotate, shape]) +existentialize _ = return Nothing + -- | When comparing index functions as part of the type check in KernelsMem, -- we may run into problems caused by the simplifier. As index functions can be -- generalized over if-then-else expressions, the simplifier might hoist some of @@ -838,7 +818,6 @@ closeEnough :: IxFun num -> IxFun num -> Bool closeEnough ixf1 ixf2 = (length (base ixf1) == length (base ixf2)) && - (ixfunContig ixf1 == ixfunContig ixf2) && (NE.length (ixfunLMADs ixf1) == NE.length (ixfunLMADs ixf2)) && all closeEnoughLMADs (NE.zip (ixfunLMADs ixf1) (ixfunLMADs ixf2)) where diff --git a/src/Futhark/IR/Mem/Simplify.hs b/src/Futhark/IR/Mem/Simplify.hs --- a/src/Futhark/IR/Mem/Simplify.hs +++ b/src/Futhark/IR/Mem/Simplify.hs @@ -33,16 +33,16 @@ import Futhark.Util simpleGeneric :: (SimplifyMemory lore, Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner + (OpWithWisdom inner -> UT.UsageTable) + -> Simplify.SimplifyOp lore inner -> Simplify.SimpleOps lore simpleGeneric = simplifiable -simplifyProgGeneric :: (SimplifyMemory lore, - Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner +simplifyProgGeneric :: (SimplifyMemory lore, Op lore ~ MemOp inner) => + Simplify.SimpleOps lore -> Prog lore -> PassM (Prog lore) -simplifyProgGeneric onInner = - Simplify.simplifyProg (simpleGeneric onInner) callKernelRules +simplifyProgGeneric ops = + Simplify.simplifyProg ops callKernelRules blockers { Engine.blockHoistBranch = blockAllocs } where blockAllocs vtable _ (Let _ _ (Op Alloc{})) = not $ ST.simplifyMemory vtable @@ -57,11 +57,11 @@ simplifyStmsGeneric :: (HasScope lore m, MonadFreshNames m, SimplifyMemory lore, Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner -> Stms lore + Simplify.SimpleOps lore -> Stms lore -> m (ST.SymbolTable (Wise lore), Stms lore) -simplifyStmsGeneric onInner stms = do +simplifyStmsGeneric ops stms = do scope <- askScope - Simplify.simplifyStms (simpleGeneric onInner) callKernelRules blockers + Simplify.simplifyStms ops callKernelRules blockers scope stms isResultAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore @@ -69,26 +69,15 @@ UT.isInResult (patElemName bindee) usage isResultAlloc _ _ _ = False --- | Getting the roots of what to hoist, for now only variable --- names that represent array and memory-block sizes. -getShapeNames :: (Mem lore, Op lore ~ MemOp op) => - Stm (Wise lore) -> Names -getShapeNames stm = - let ts = map patElemType $ patternElements $ stmPattern stm - in freeIn (concatMap arrayDims ts) <> - case stmExp stm of Op (Alloc size _) -> freeIn size - _ -> mempty - isAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore isAlloc _ _ (Let _ _ (Op Alloc{})) = True isAlloc _ _ _ = False -blockers :: (Mem lore, Op lore ~ MemOp inner) => +blockers :: (Op lore ~ MemOp inner) => Simplify.HoistBlockers lore blockers = Engine.noExtraHoistBlockers { Engine.blockHoistPar = isAlloc , Engine.blockHoistSeq = isResultAlloc - , Engine.getArraySizes = getShapeNames , Engine.isAllocation = isAlloc mempty mempty } @@ -109,8 +98,9 @@ RuleIf unExistentialiseMemory] [] -- | If a branch is returning some existential memory, but the size of --- the array is not existential, then we can create a block of the --- proper size and always return there. +-- the array is not existential, and the index function of the array +-- does not refer to any names in the pattern, then we can create a +-- block of the proper size and always return there. unExistentialiseMemory :: SimplifyMemory lore => TopDownRuleIf (Wise lore) unExistentialiseMemory vtable pat _ (cond, tbranch, fbranch, ifdec) | ST.simplifyMemory vtable, @@ -162,6 +152,7 @@ Just fse <- maybeNth j $ bodyResult fbranch, mem `onlyUsedIn` patElemName pat_elem, all knownSize (shapeDims shape), + not $ freeIn ixfun `namesIntersect` namesFromList (patternNames pat), fse /= tse = let mem_size = ConvOpExp (SExt Int32 Int64) $ diff --git a/src/Futhark/IR/Pretty.hs b/src/Futhark/IR/Pretty.hs --- a/src/Futhark/IR/Pretty.hs +++ b/src/Futhark/IR/Pretty.hs @@ -120,11 +120,15 @@ instance Pretty Attr where ppr (AttrAtom v) = ppr v + ppr (AttrComp f attrs) = ppr f <> parens (commasep $ map ppr attrs) -attrAnnots :: Stm lore -> [Doc] -attrAnnots = map f . toList . unAttrs . stmAuxAttrs . stmAux +attrAnnots :: Attrs -> [Doc] +attrAnnots = map f . toList . unAttrs where f v = text "#[" <> ppr v <> text "]" +stmAttrAnnots :: Stm lore -> [Doc] +stmAttrAnnots = attrAnnots . stmAuxAttrs . stmAux + instance Pretty (PatElemT dec) => Pretty (PatternT dec) where ppr pat = ppPattern (patternContextElements pat) (patternValueElements pat) @@ -167,10 +171,10 @@ _ -> cs /= mempty stmannot = - case attrAnnots bnd <> - mapMaybe ppAnnot (patternElements $ stmPattern bnd) of + case stmAttrAnnots bnd <> + mapMaybe ppAnnot (patternElements $ stmPattern bnd) of [] -> id - annots -> (stack annots ) + annots -> (align (stack annots) ) instance Pretty BasicOp where ppr (SubExp se) = ppr se @@ -196,8 +200,6 @@ where et' = text $ show $ primBitSize $ IntType et ppr (Replicate ne ve) = text "replicate" <> apply [ppr ne, align (ppr ve)] - ppr (Repeat shapes innershape v) = - text "repeat" <> apply [apply $ map ppr $ shapes ++ [innershape], ppr v] ppr (Scratch t shape) = text "scratch" <> apply (ppr t : map ppr shape) ppr (Reshape shape e) = @@ -265,8 +267,8 @@ text "=>" indent 2 (ppr body) instance PrettyLore lore => Pretty (FunDef lore) where - ppr (FunDef entry name rettype fparams body) = - annot (mapMaybe ppAnnot fparams) $ + ppr (FunDef entry attrs name rettype fparams body) = + annot (mapMaybe ppAnnot fparams <> attrAnnots attrs) $ text fun <+> ppTuple' rettype <+/> text (nameToString name) <+> apply (map ppr fparams) <+> 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 @@ -24,6 +24,7 @@ -- * Operations , Overflow (..) + , Safety(..) , UnOp (..), allUnOps , BinOp (..), allBinOps , ConvOp (..), allConvOps @@ -296,6 +297,24 @@ instance Ord Overflow where _ `compare` _ = EQ +-- | Whether something is safe or unsafe (mostly function calls, and +-- in the context of whether operations are dynamically checked). +-- When we inline an 'Unsafe' function, we remove all safety checks in +-- its body. The 'Ord' instance picks 'Unsafe' as being less than +-- 'Safe'. +-- +-- For operations like integer division, a safe division will not +-- explode the computer in case of division by zero, but instead +-- return some unspecified value. This always involves a run-time +-- check, so generally the unsafe variant is what the compiler will +-- insert, but guarded by an explicit assertion elsewhere. Safe +-- operations are useful when the optimiser wants to move e.g. a +-- division to a location where the divisor may be zero, but where the +-- result will only be used when it is non-zero (so it doesn't matter +-- what result is provided with a zero divisor, as long as the program +-- keeps running). +data Safety = Unsafe | Safe deriving (Eq, Ord, Show) + -- | Binary operators. These correspond closely to the binary operators in -- LLVM. Most are parametrised by their expected input and output -- types. @@ -308,28 +327,38 @@ | Mul IntType Overflow -- ^ Integer multiplication. | FMul FloatType -- ^ Floating-point multiplication. - | UDiv IntType + | UDiv IntType Safety -- ^ Unsigned integer division. Rounds towards -- negativity infinity. Note: this is different -- from LLVM. - | SDiv IntType + | UDivUp IntType Safety + -- ^ Unsigned integer division. Rounds towards positive + -- infinity. + + | SDiv IntType Safety -- ^ Signed integer division. Rounds towards -- negativity infinity. Note: this is different -- from LLVM. + | SDivUp IntType Safety + -- ^ Signed integer division. Rounds towards positive + -- infinity. + | FDiv FloatType -- ^ Floating-point division. | FMod FloatType -- ^ Floating-point modulus. - | UMod IntType + | UMod IntType Safety -- ^ Unsigned integer modulus; the countepart to 'UDiv'. - | SMod IntType + | SMod IntType Safety -- ^ Signed integer modulus; the countepart to 'SDiv'. - | SQuot IntType - -- ^ Signed integer division. Rounds towards zero. - -- This corresponds to the @sdiv@ instruction in LLVM. - | SRem IntType - -- ^ Signed integer division. Rounds towards zero. - -- This corresponds to the @srem@ instruction in LLVM. + | SQuot IntType Safety + -- ^ Signed integer division. Rounds towards zero. This + -- corresponds to the @sdiv@ instruction in LLVM and + -- integer division in C. + | SRem IntType Safety + -- ^ Signed integer division. Rounds towards zero. This + -- corresponds to the @srem@ instruction in LLVM and + -- integer modulo in C. | SMin IntType -- ^ Returns the smallest of two signed integers. @@ -427,14 +456,16 @@ , map FSub allFloatTypes , map (`Mul` OverflowWrap) allIntTypes , map FMul allFloatTypes - , map UDiv allIntTypes - , map SDiv allIntTypes + , map (`UDiv` Unsafe) allIntTypes + , map (`UDivUp` Unsafe) allIntTypes + , map (`SDiv` Unsafe) allIntTypes + , map (`SDivUp` Unsafe) allIntTypes , map FDiv allFloatTypes , map FMod allFloatTypes - , map UMod allIntTypes - , map SMod allIntTypes - , map SQuot allIntTypes - , map SRem allIntTypes + , map (`UMod` Unsafe) allIntTypes + , map (`SMod` Unsafe) allIntTypes + , map (`SQuot` Unsafe) allIntTypes + , map (`SRem` Unsafe) allIntTypes , map SMin allIntTypes , map UMin allIntTypes , map FMin allFloatTypes @@ -518,7 +549,9 @@ doBinOp Mul{} = doIntBinOp doMul doBinOp FMul{} = doFloatBinOp (*) (*) doBinOp UDiv{} = doRiskyIntBinOp doUDiv +doBinOp UDivUp{} = doRiskyIntBinOp doUDivUp doBinOp SDiv{} = doRiskyIntBinOp doSDiv +doBinOp SDivUp{} = doRiskyIntBinOp doSDivUp doBinOp FDiv{} = doFloatBinOp (/) (/) doBinOp FMod{} = doFloatBinOp mod' mod' doBinOp UMod{} = doRiskyIntBinOp doUMod @@ -582,22 +615,36 @@ doMul :: IntValue -> IntValue -> IntValue doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 --- | Unsigned integer division. Rounds towards --- negativity infinity. Note: this is different --- from LLVM. +-- | Unsigned integer division. Rounds towards negativity infinity. +-- Note: this is different from LLVM. doUDiv :: IntValue -> IntValue -> Maybe IntValue doUDiv v1 v2 | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `div` intToWord64 v2 + | otherwise = Just $ intValue (intValueType v1) $ + intToWord64 v1 `div` intToWord64 v2 --- | Signed integer division. Rounds towards --- negativity infinity. Note: this is different --- from LLVM. +-- | Unsigned integer division. Rounds towards positive infinity. +doUDivUp :: IntValue -> IntValue -> Maybe IntValue +doUDivUp v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ + (intToWord64 v1 + intToWord64 v2 - 1) `div` intToWord64 v2 + +-- | Signed integer division. Rounds towards negativity infinity. +-- Note: this is different from LLVM. doSDiv :: IntValue -> IntValue -> Maybe IntValue doSDiv v1 v2 | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `div` intToInt64 v2 + | otherwise = Just $ intValue (intValueType v1) $ + intToInt64 v1 `div` intToInt64 v2 +-- | Signed integer division. Rounds towards positive infinity. +doSDivUp :: IntValue -> IntValue -> Maybe IntValue +doSDivUp v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ + (intToInt64 v1 + intToInt64 v2 - 1) `div` intToInt64 v2 + -- | Unsigned integer modulus; the countepart to 'UDiv'. doUMod :: IntValue -> IntValue -> Maybe IntValue doUMod v1 v2 @@ -796,12 +843,14 @@ binOpType (Add t _) = IntType t binOpType (Sub t _) = IntType t binOpType (Mul t _) = IntType t -binOpType (SDiv t) = IntType t -binOpType (SMod t) = IntType t -binOpType (SQuot t) = IntType t -binOpType (SRem t) = IntType t -binOpType (UDiv t) = IntType t -binOpType (UMod t) = IntType t +binOpType (SDiv t _) = IntType t +binOpType (SDivUp t _) = IntType t +binOpType (SMod t _) = IntType t +binOpType (SQuot t _) = IntType t +binOpType (SRem t _) = IntType t +binOpType (UDiv t _) = IntType t +binOpType (UDivUp t _) = IntType t +binOpType (UMod t _) = IntType t binOpType (SMin t) = IntType t binOpType (UMin t) = IntType t binOpType (FMin t) = FloatType t @@ -1176,12 +1225,22 @@ ppr (FAdd t) = taggedF "fadd" t ppr (FSub t) = taggedF "fsub" t ppr (FMul t) = taggedF "fmul" t - ppr (UDiv t) = taggedI "udiv" t - ppr (UMod t) = taggedI "umod" t - ppr (SDiv t) = taggedI "sdiv" t - ppr (SMod t) = taggedI "smod" t - ppr (SQuot t) = taggedI "squot" t - ppr (SRem t) = taggedI "srem" t + ppr (UDiv t Safe) = taggedI "udiv_safe" t + ppr (UDiv t Unsafe) = taggedI "udiv" t + ppr (UDivUp t Safe) = taggedI "udiv_up_safe" t + ppr (UDivUp t Unsafe) = taggedI "udiv_up" t + ppr (UMod t Safe) = taggedI "umod_safe" t + ppr (UMod t Unsafe) = taggedI "umod" t + ppr (SDiv t Safe) = taggedI "sdiv_safe" t + ppr (SDiv t Unsafe) = taggedI "sdiv" t + ppr (SDivUp t Safe) = taggedI "sdiv_up_safe" t + ppr (SDivUp t Unsafe) = taggedI "sdiv_up" t + ppr (SMod t Safe) = taggedI "smod_safe" t + ppr (SMod t Unsafe) = taggedI "smod" t + ppr (SQuot t Safe) = taggedI "squot_safe" t + ppr (SQuot t Unsafe) = taggedI "squot" t + ppr (SRem t Safe) = taggedI "srem_safe" t + ppr (SRem t Unsafe) = taggedI "srem" t ppr (FDiv t) = taggedF "fdiv" t ppr (FMod t) = taggedF "fmod" t ppr (SMin t) = taggedI "smin" t 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 @@ -1,4 +1,8 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Safe #-} -- | This module provides various simple ways to query and manipulate -- fundamental Futhark terms, such as types and values. The intent is to @@ -31,6 +35,7 @@ , stmCerts , certify , expExtTypesFromPattern + , attrsForAssert , ASTConstraints , IsOp (..) @@ -41,6 +46,7 @@ import Data.List (find) import Data.Maybe (mapMaybe, isJust) import qualified Data.Map.Strict as M +import qualified Data.Set as S import Futhark.IR.Prop.Reshape import Futhark.IR.Prop.Rearrange @@ -76,10 +82,23 @@ -- bounds. On the other hand, adding two numbers cannot fail. safeExp :: IsOp (Op lore) => Exp lore -> Bool safeExp (BasicOp op) = safeBasicOp op - where safeBasicOp (BinOp SDiv{} _ (Constant y)) = not $ zeroIsh y + where safeBasicOp (BinOp (SDiv _ Safe) _ _) = True + safeBasicOp (BinOp (SDivUp _ Safe) _ _) = True + safeBasicOp (BinOp (SQuot _ Safe) _ _) = True + safeBasicOp (BinOp (UDiv _ Safe) _ _) = True + safeBasicOp (BinOp (UDivUp _ Safe) _ _) = True + safeBasicOp (BinOp (SMod _ Safe) _ _) = True + safeBasicOp (BinOp (SRem _ Safe) _ _) = True + safeBasicOp (BinOp (UMod _ Safe) _ _) = True + + safeBasicOp (BinOp SDiv{} _ (Constant y)) = not $ zeroIsh y safeBasicOp (BinOp SDiv{} _ _) = False + safeBasicOp (BinOp SDivUp{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp SDivUp{} _ _) = False safeBasicOp (BinOp UDiv{} _ (Constant y)) = not $ zeroIsh y safeBasicOp (BinOp UDiv{} _ _) = False + safeBasicOp (BinOp UDivUp{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp UDivUp{} _ _) = False safeBasicOp (BinOp SMod{} _ (Constant y)) = not $ zeroIsh y safeBasicOp (BinOp SMod{} _ _) = False safeBasicOp (BinOp UMod{} _ (Constant y)) = not $ zeroIsh y @@ -221,3 +240,10 @@ expExtTypesFromPattern pat = existentialiseExtTypes (patternContextNames pat) $ staticShapes $ map patElemType $ patternValueElements pat + +-- | Keep only those attributes that are relevant for 'Assert' +-- expressions. +attrsForAssert :: Attrs -> Attrs +attrsForAssert (Attrs attrs) = + Attrs $ S.filter attrForAssert attrs + where attrForAssert = (==AttrComp "warn" ["safety_checks"]) diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs --- a/src/Futhark/IR/Prop/Aliases.hs +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -62,7 +62,6 @@ basicOpAliases Update{} = [mempty] basicOpAliases Iota{} = [mempty] basicOpAliases Replicate{} = [mempty] -basicOpAliases (Repeat _ _ v) = [vnameAliases v] basicOpAliases Scratch{} = [mempty] basicOpAliases (Reshape _ e) = [vnameAliases e] basicOpAliases (Rearrange _ e) = [vnameAliases e] 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 @@ -6,6 +6,7 @@ module Futhark.IR.Prop.Names ( -- * Free names Names + , namesIntMap , nameIn , oneName , namesFromList @@ -44,12 +45,20 @@ import Futhark.IR.Prop.Scope import Futhark.Util.Pretty --- | A set of names. -newtype Names = Names { unNames :: IM.IntMap VName } +-- | A set of names. Note that the 'Ord' instance is a dummy that +-- treats everything as 'EQ' if '==', and otherwise 'LT'. +newtype Names = Names (IM.IntMap VName) deriving (Eq, Show) +-- | Retrieve the data structure underlying the names representation. +namesIntMap :: Names -> IM.IntMap VName +namesIntMap (Names m) = m + +instance Ord Names where + x `compare` y = if x == y then EQ else LT + instance Semigroup Names where - vs1 <> vs2 = Names $ unNames vs1 <> unNames vs2 + vs1 <> vs2 = Names $ namesIntMap vs1 <> namesIntMap vs2 instance Monoid Names where mempty = Names mempty @@ -67,7 +76,7 @@ -- | Turn a name set into a list of names. Slow. namesToList :: Names -> [VName] -namesToList = IM.elems . unNames +namesToList = IM.elems . namesIntMap -- | Construct a name set from a single name. oneName :: VName -> Names @@ -79,7 +88,7 @@ -- | Do the two name sets intersect? namesIntersect :: Names -> Names -> Bool -namesIntersect vs1 vs2 = not $ IM.disjoint (unNames vs1) (unNames vs2) +namesIntersect vs1 vs2 = not $ IM.disjoint (namesIntMap vs1) (namesIntMap vs2) -- | Subtract the latter name set from the former. namesSubtract :: Names -> Names -> Names @@ -175,7 +184,7 @@ FreeIn (LetDec lore), FreeIn (RetType lore), FreeIn (Op lore)) => FreeIn (FunDef lore) where - freeIn' (FunDef _ _ rettype params body) = + freeIn' (FunDef _ _ _ rettype params body) = fvBind (namesFromList $ map paramName params) $ freeIn' rettype <> freeIn' params <> freeIn' body @@ -316,6 +325,9 @@ instance FreeDec a => FreeDec (Maybe a) where precomputed Nothing = id precomputed (Just a) = precomputed a + +instance FreeDec Names where + precomputed _ fv = fv -- | The names bound by the bindings immediately in a t'Body'. boundInBody :: Body lore -> Names diff --git a/src/Futhark/IR/Prop/Ranges.hs b/src/Futhark/IR/Prop/Ranges.hs deleted file mode 100644 --- a/src/Futhark/IR/Prop/Ranges.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | Utility declarations for performing range analysis. The ranges --- computed here are /local/ (does not take range of subexpressions --- into account), which is probably not very interesting. See --- "Futhark.Analysis.Range" for a more comprehensive analysis built on --- these building blocks. -module Futhark.IR.Prop.Ranges - ( Bound - , KnownBound (..) - , boundToScalExp - , minimumBound - , maximumBound - , Range - , unknownRange - , ScalExpRange - , Ranged - , RangeOf (..) - , RangesOf (..) - , expRanges - , RangedOp (..) - , CanBeRanged (..) - ) - where - -import qualified Data.Kind -import qualified Data.Map.Strict as M - -import Futhark.IR.Prop -import Futhark.IR.Syntax -import qualified Futhark.Analysis.ScalExp as SE -import qualified Futhark.Analysis.AlgSimplify as AS -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import qualified Futhark.Util.Pretty as PP - --- | A known bound on a value. -data KnownBound = VarBound VName - -- ^ Has the same bounds as this variable. VERY - -- IMPORTANT: this variable may be an array, so it - -- cannot be immediately translated to a 'SE.ScalExp'. - | MinimumBound KnownBound KnownBound - -- ^ Bounded by the minimum of these two bounds. - | MaximumBound KnownBound KnownBound - -- ^ Bounded by the maximum of these two bounds. - | ScalarBound SE.ScalExp - -- ^ Bounded by this scalar expression. - deriving (Eq, Ord, Show) - -instance Substitute KnownBound where - substituteNames substs (VarBound name) = - VarBound $ substituteNames substs name - substituteNames substs (MinimumBound b1 b2) = - MinimumBound (substituteNames substs b1) (substituteNames substs b2) - substituteNames substs (MaximumBound b1 b2) = - MaximumBound (substituteNames substs b1) (substituteNames substs b2) - substituteNames substs (ScalarBound se) = - ScalarBound $ substituteNames substs se - -instance Rename KnownBound where - rename = substituteRename - -instance FreeIn KnownBound where - freeIn' (VarBound v) = freeIn' v - freeIn' (MinimumBound b1 b2) = freeIn' b1 <> freeIn' b2 - freeIn' (MaximumBound b1 b2) = freeIn' b1 <> freeIn' b2 - freeIn' (ScalarBound e) = freeIn' e - -instance FreeDec KnownBound where - precomputed _ = id - -instance PP.Pretty KnownBound where - ppr (VarBound v) = - PP.text "variable " <> PP.ppr v - ppr (MinimumBound b1 b2) = - PP.text "min" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) - ppr (MaximumBound b1 b2) = - PP.text "max" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) - ppr (ScalarBound e) = - PP.ppr e - --- | Convert the bound to a scalar expression if possible. This is --- possible for all bounds that do not contain 'VarBound's. -boundToScalExp :: KnownBound -> Maybe SE.ScalExp -boundToScalExp (VarBound _) = Nothing -boundToScalExp (ScalarBound se) = Just se -boundToScalExp (MinimumBound b1 b2) = do - b1' <- boundToScalExp b1 - b2' <- boundToScalExp b2 - return $ SE.MaxMin True [b1', b2'] -boundToScalExp (MaximumBound b1 b2) = do - b1' <- boundToScalExp b1 - b2' <- boundToScalExp b2 - return $ SE.MaxMin False [b1', b2'] - --- | A possibly undefined bound on a value. -type Bound = Maybe KnownBound - --- | Construct a 'MinimumBound' from two possibly known bounds. The --- resulting bound will be unknown unless both of the given 'Bound's --- are known. This may seem counterintuitive, but it actually makes --- sense when you consider the task of combining the lower bounds for --- two different flows of execution (like an @if@ expression). If we --- only have knowledge about one of the branches, this means that we --- have no useful information about the combined lower bound, as the --- other branch may take any value. -minimumBound :: Bound -> Bound -> Bound -minimumBound (Just x) (Just y) = Just $ MinimumBound x y -minimumBound _ _ = Nothing - --- | Like 'minimumBound', but constructs a 'MaximumBound'. -maximumBound :: Bound -> Bound -> Bound -maximumBound (Just x) (Just y) = Just $ MaximumBound x y -maximumBound _ _ = Nothing - --- | Upper and lower bound, both inclusive. -type Range = (Bound, Bound) - --- | A range in which both upper and lower bounds are 'Nothing. -unknownRange :: Range -unknownRange = (Nothing, Nothing) - --- | The range as a pair of scalar expressions. -type ScalExpRange = (Maybe SE.ScalExp, Maybe SE.ScalExp) - --- | The lore has embedded range information. Note that it may not be --- up to date, unless whatever maintains the syntax tree is careful. -type Ranged lore = (ASTLore lore, - RangedOp (Op lore), - RangeOf (LetDec lore), - RangesOf (BodyDec lore)) - --- | Something that contains range information. -class RangeOf a where - -- | The range of the argument element. - rangeOf :: a -> Range - -instance RangeOf Range where - rangeOf = id - -instance RangeOf dec => RangeOf (PatElemT dec) where - rangeOf = rangeOf . patElemDec - -instance RangeOf SubExp where - rangeOf se = (Just lower, Just upper) - where (lower, upper) = subExpKnownRange se - --- | Something that contains range information for several things, --- most notably t'Body' and t'Pattern'. -class RangesOf a where - -- | The ranges of the argument. - rangesOf :: a -> [Range] - -instance RangeOf a => RangesOf [a] where - rangesOf = map rangeOf - -instance RangeOf dec => RangesOf (PatternT dec) where - rangesOf = map rangeOf . patternElements - -instance Ranged lore => RangesOf (Body lore) where - rangesOf = rangesOf . bodyDec - -subExpKnownRange :: SubExp -> (KnownBound, KnownBound) -subExpKnownRange (Var v) = - (VarBound v, - VarBound v) -subExpKnownRange (Constant val) = - (ScalarBound $ SE.Val val, - ScalarBound $ SE.Val val) - --- | The range of a scalar expression. -scalExpRange :: SE.ScalExp -> Range -scalExpRange se = - (Just $ ScalarBound se, Just $ ScalarBound se) - -primOpRanges :: BasicOp -> [Range] -primOpRanges (SubExp se) = - [rangeOf se] - -primOpRanges (BinOp (Add t _) x y) = - [scalExpRange $ SE.SPlus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (Sub t _) x y) = - [scalExpRange $ SE.SMinus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (Mul t _) x y) = - [scalExpRange $ SE.STimes (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (SDiv t) x y) = - [scalExpRange $ SE.SDiv (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] - -primOpRanges (ConvOp (SExt from to) x) - | from < to = [rangeOf x] - -primOpRanges (ConvOp (BToI it) _) = - [(Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (0::Int), - Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (1::Int))] - -primOpRanges (Iota n x s Int32) = - [(Just $ ScalarBound x', - Just $ ScalarBound $ x' + (n' - 1) * s')] - where n' = case n of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val - x' = case x of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val - s' = case s of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val -primOpRanges (Replicate _ v) = - [rangeOf v] -primOpRanges (Rearrange _ v) = - [rangeOf $ Var v] -primOpRanges (Copy se) = - [rangeOf $ Var se] -primOpRanges (Index v _) = - [rangeOf $ Var v] -primOpRanges (ArrayLit (e:es) _) = - [(Just lower, Just upper)] - where (e_lower, e_upper) = subExpKnownRange e - (es_lower, es_upper) = unzip $ map subExpKnownRange es - lower = foldl MinimumBound e_lower es_lower - upper = foldl MaximumBound e_upper es_upper -primOpRanges _ = - [unknownRange] - --- | Ranges of the value parts of the expression. -expRanges :: Ranged lore => - Exp lore -> [Range] -expRanges (BasicOp op) = - primOpRanges op -expRanges (If _ tbranch fbranch _) = - zip - (zipWith minimumBound t_lower f_lower) - (zipWith maximumBound t_upper f_upper) - where (t_lower, t_upper) = unzip $ rangesOf tbranch - (f_lower, f_upper) = unzip $ rangesOf fbranch -expRanges (DoLoop ctxmerge valmerge (ForLoop i Int32 iterations _) body) = - zipWith returnedRange valmerge $ rangesOf body - where bound_in_loop = - namesFromList $ i : map (paramName . fst) (ctxmerge++valmerge) ++ - concatMap (patternNames . stmPattern) (bodyStms body) - - returnedRange mergeparam (lower, upper) = - (returnedBound mergeparam lower, - returnedBound mergeparam upper) - - returnedBound (param, mergeinit) (Just bound) - | paramType param == Prim (IntType Int32), - Just bound' <- boundToScalExp bound, - let se_diff = - AS.simplify (SE.SMinus (SE.Id (paramName param) $ IntType Int32) bound') M.empty, - namesIntersect bound_in_loop $ freeIn se_diff = - Just $ ScalarBound $ SE.SPlus (SE.subExpToScalExp mergeinit $ IntType Int32) $ - SE.STimes se_diff $ SE.MaxMin False - [SE.subExpToScalExp iterations $ IntType Int32, 0] - returnedBound _ _ = Nothing -expRanges (Op ranges) = opRanges ranges -expRanges e = - replicate (expExtTypeSize e) unknownRange - --- | The class of operations that can produce range information. -class IsOp op => RangedOp op where - opRanges :: op -> [Range] - -instance RangedOp () where - opRanges () = [] - --- | The class of operations that can be given ranging information. --- This is a somewhat subtle concept that is only used in the --- simplifier and when using "lore adapters". -class RangedOp (OpWithRanges op) => - CanBeRanged op where - type OpWithRanges op :: Data.Kind.Type - removeOpRanges :: OpWithRanges op -> op - addOpRanges :: op -> OpWithRanges op - -instance CanBeRanged () where - type OpWithRanges () = () - removeOpRanges = id - addOpRanges = id diff --git a/src/Futhark/IR/Prop/Reshape.hs b/src/Futhark/IR/Prop/Reshape.hs --- a/src/Futhark/IR/Prop/Reshape.hs +++ b/src/Futhark/IR/Prop/Reshape.hs @@ -9,12 +9,10 @@ -- * Construction , shapeCoerce - , repeatShapes -- * Execution , reshapeOuter , reshapeInner - , repeatDims -- * Inspection , shapeCoercion @@ -35,7 +33,6 @@ import Prelude hiding (sum, product, quot) -import Futhark.IR.Prop.Types import Futhark.IR.Syntax import Futhark.Util.IntegralExp @@ -57,23 +54,6 @@ shapeCoerce :: [SubExp] -> VName -> Exp lore shapeCoerce newdims arr = BasicOp $ Reshape (map DimCoercion newdims) arr - --- | Construct a pair suitable for a 'Repeat'. -repeatShapes :: [Shape] -> Type -> ([Shape], Shape) -repeatShapes shapes t = - case splitAt t_rank shapes of - (outer_shapes, [inner_shape]) -> - (outer_shapes, inner_shape) - _ -> - (shapes ++ replicate (length shapes - t_rank) (Shape []), Shape []) - where t_rank = arrayRank t - --- | Modify the shape of an array type as 'Repeat' would do -repeatDims :: [Shape] -> Shape -> Type -> Type -repeatDims shape innershape = modifyArrayShape repeatDims' - where repeatDims' (Shape ds) = - Shape $ concat (zipWith (++) (map shapeDims shape) (map pure ds)) ++ - shapeDims innershape -- | @reshapeOuter newshape n oldshape@ returns a 'Reshape' expression -- that replaces the outer @n@ dimensions of @oldshape@ with @newshape@. diff --git a/src/Futhark/IR/Prop/TypeOf.hs b/src/Futhark/IR/Prop/TypeOf.hs --- a/src/Futhark/IR/Prop/TypeOf.hs +++ b/src/Futhark/IR/Prop/TypeOf.hs @@ -84,8 +84,6 @@ pure [arrayOf (Prim (IntType et)) (Shape [n]) NoUniqueness] primOpType (Replicate (Shape []) e) = pure <$> subExpType e -primOpType (Repeat shape innershape v) = - pure . repeatDims shape innershape <$> lookupType v primOpType (Replicate shape e) = pure . flip arrayOfShape shape <$> subExpType e primOpType (Scratch t shape) = diff --git a/src/Futhark/IR/Ranges.hs b/src/Futhark/IR/Ranges.hs deleted file mode 100644 --- a/src/Futhark/IR/Ranges.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | A representation where all bindings are annotated with range --- information. -module Futhark.IR.Ranges - ( -- * The Lore definition - Ranges - , module Futhark.IR.Prop.Ranges - -- * Module re-exports - , module Futhark.IR.Prop - , module Futhark.IR.Traversals - , module Futhark.IR.Pretty - , module Futhark.IR.Syntax - -- * Adding ranges - , addRangesToPattern - , mkRangedBody - , mkPatternRanges - , mkBodyRanges - -- * Removing ranges - , removeProgRanges - , removeStmRanges - , removeLambdaRanges - ) -where - -import Control.Monad.Identity -import Control.Monad.Reader - -import Futhark.IR.Syntax -import Futhark.IR.Prop -import Futhark.IR.Prop.Aliases -import Futhark.IR.Prop.Ranges -import Futhark.IR.Traversals -import Futhark.IR.Pretty -import Futhark.Analysis.Rephrase -import qualified Futhark.Util.Pretty as PP - --- | The lore for the basic representation. -data Ranges lore - -instance (Decorations lore, CanBeRanged (Op lore)) => - Decorations (Ranges lore) where - type LetDec (Ranges lore) = (Range, LetDec lore) - type ExpDec (Ranges lore) = ExpDec lore - type BodyDec (Ranges lore) = ([Range], BodyDec lore) - type FParamInfo (Ranges lore) = FParamInfo lore - type LParamInfo (Ranges lore) = LParamInfo lore - type RetType (Ranges lore) = RetType lore - type BranchType (Ranges lore) = BranchType lore - type Op (Ranges lore) = OpWithRanges (Op lore) - -withoutRanges :: (HasScope (Ranges lore) m, Monad m) => - ReaderT (Scope lore) m a -> - m a -withoutRanges m = do - scope <- asksScope $ fmap unRange - runReaderT m scope - where unRange :: NameInfo (Ranges lore) -> NameInfo lore - unRange (LetName (_, x)) = LetName x - unRange (FParamName x) = FParamName x - unRange (LParamName x) = LParamName x - unRange (IndexName x) = IndexName x - -instance (ASTLore lore, CanBeRanged (Op lore)) => - ASTLore (Ranges lore) where - expTypesFromPattern = - withoutRanges . expTypesFromPattern . removePatternRanges - -instance RangeOf (Range, dec) where - rangeOf = fst - -instance RangesOf ([Range], dec) where - rangesOf = fst - -instance PrettyAnnot (PatElemT dec) => - PrettyAnnot (PatElemT (Range, dec)) where - - ppAnnot patelem = - range_annot <> inner_annot - where range_annot = - case fst . patElemDec $ patelem of - (Nothing, Nothing) -> Nothing - range -> - Just $ PP.oneLine $ - PP.text "-- " <> PP.ppr (patElemName patelem) <> PP.text " range: " <> - PP.ppr range - inner_annot = ppAnnot $ fmap snd patelem - - -instance (PrettyLore lore, CanBeRanged (Op lore)) => PrettyLore (Ranges lore) where - ppExpLore dec = ppExpLore dec . removeExpRanges - -removeRanges :: CanBeRanged (Op lore) => Rephraser Identity (Ranges lore) lore -removeRanges = Rephraser { rephraseExpLore = return - , rephraseLetBoundLore = return . snd - , rephraseBodyLore = return . snd - , rephraseFParamLore = return - , rephraseLParamLore = return - , rephraseRetType = return - , rephraseBranchType = return - , rephraseOp = return . removeOpRanges - } - --- | Remove range information from program. -removeProgRanges :: CanBeRanged (Op lore) => - Prog (Ranges lore) -> Prog lore -removeProgRanges = runIdentity . rephraseProg removeRanges - -removeExpRanges :: CanBeRanged (Op lore) => - Exp (Ranges lore) -> Exp lore -removeExpRanges = runIdentity . rephraseExp removeRanges - -removeBodyRanges :: CanBeRanged (Op lore) => - Body (Ranges lore) -> Body lore -removeBodyRanges = runIdentity . rephraseBody removeRanges - --- | Remove range information from statement. -removeStmRanges :: CanBeRanged (Op lore) => - Stm (Ranges lore) -> Stm lore -removeStmRanges = runIdentity . rephraseStm removeRanges - --- | Remove range information from lambda. -removeLambdaRanges :: CanBeRanged (Op lore) => - Lambda (Ranges lore) -> Lambda lore -removeLambdaRanges = runIdentity . rephraseLambda removeRanges - -removePatternRanges :: PatternT (Range, a) - -> PatternT a -removePatternRanges = runIdentity . rephrasePattern (return . snd) - --- | Add ranges to the pattern corresponding to this expression. -addRangesToPattern :: (ASTLore lore, CanBeRanged (Op lore)) => - Pattern lore -> Exp (Ranges lore) - -> Pattern (Ranges lore) -addRangesToPattern pat e = - uncurry Pattern $ mkPatternRanges pat e - --- | Construct a body with the 'Ranges' lore. -mkRangedBody :: BodyDec lore -> Stms (Ranges lore) -> Result - -> Body (Ranges lore) -mkRangedBody innerlore bnds res = - Body (mkBodyRanges bnds res, innerlore) bnds res - --- | Find the ranges for the pattern elements. -mkPatternRanges :: (ASTLore lore, CanBeRanged (Op lore)) => - Pattern lore - -> Exp (Ranges lore) - -> ([PatElemT (Range, LetDec lore)], - [PatElemT (Range, LetDec lore)]) -mkPatternRanges pat e = - (map (`addRanges` unknownRange) $ patternContextElements pat, - zipWith addRanges (patternValueElements pat) ranges) - where addRanges patElem range = - let innerlore = patElemDec patElem - in patElem `setPatElemLore` (range, innerlore) - ranges = expRanges e - --- | Find the ranges for the body result. -mkBodyRanges :: Stms lore -> Result -> [Range] -mkBodyRanges bnds = map $ removeUnknownBounds . rangeOf - where boundInBnds = - foldMap (namesFromList . patternNames . stmPattern) bnds - removeUnknownBounds (lower,upper) = - (removeUnknownBound lower, - removeUnknownBound upper) - removeUnknownBound (Just bound) - | freeIn bound `namesIntersect` boundInBnds = Nothing - | otherwise = Just bound - removeUnknownBound Nothing = - Nothing - --- It is convenient for a wrapped aliased lore to also be aliased. - -instance AliasesOf dec => AliasesOf ([Range], dec) where - aliasesOf = aliasesOf . snd - -instance AliasesOf dec => AliasesOf (Range, dec) where - aliasesOf = aliasesOf . snd - -instance (Aliased lore, CanBeRanged (Op lore), - AliasedOp (OpWithRanges (Op lore))) => Aliased (Ranges lore) where - bodyAliases = bodyAliases . removeBodyRanges - consumedInBody = consumedInBody . removeBodyRanges diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs --- a/src/Futhark/IR/SOACS/SOAC.hs +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -65,14 +65,11 @@ import Futhark.Transform.Substitute import Futhark.Transform.Rename import Futhark.Optimise.Simplify.Lore -import Futhark.IR.Ranges (Ranges, removeLambdaRanges) -import Futhark.IR.Prop.Ranges import Futhark.IR.Aliases (Aliases, removeLambdaAliases) import qualified Futhark.Analysis.SymbolTable as ST import Futhark.Analysis.PrimExp.Convert import qualified Futhark.TypeCheck as TC import Futhark.Analysis.Metrics -import qualified Futhark.Analysis.Range as Range import Futhark.Construct import Futhark.Util (maybeNth, chunks) @@ -451,40 +448,6 @@ substNamesInSubExp _ e@(Constant _) = e substNamesInSubExp subs (Var idd) = M.findWithDefault (Var idd) idd subs - -instance (Ranged inner) => RangedOp (SOAC inner) where - opRanges op = replicate (length $ soacType op) unknownRange - -instance (ASTLore lore, CanBeRanged (Op lore)) => CanBeRanged (SOAC lore) where - type OpWithRanges (SOAC lore) = SOAC (Ranges lore) - - removeOpRanges = runIdentity . mapSOACM remove - where remove = SOACMapper return (return . removeLambdaRanges) return - addOpRanges (Stream w form lam arr) = - Stream w - (Range.runRangeM $ analyseStreamForm form) - (Range.runRangeM $ Range.analyseLambda lam) - arr - where analyseStreamForm (Sequential acc) = - return $ Sequential acc - analyseStreamForm (Parallel o comm lam0 acc) = do - lam0' <- Range.analyseLambda lam0 - return $ Parallel o comm lam0' acc - addOpRanges (Scatter len lam ivs as) = - Scatter len (Range.runRangeM $ Range.analyseLambda lam) ivs as - addOpRanges (Hist len ops bucket_fun imgs) = - Hist len (map (mapHistOp $ Range.runRangeM . Range.analyseLambda) ops) - (Range.runRangeM $ Range.analyseLambda bucket_fun) imgs - addOpRanges (Screma w (ScremaForm scans reds map_lam) arrs) = - Screma w (ScremaForm - (map onScan scans) - (map onRed reds) - (Range.runRangeM $ Range.analyseLambda map_lam)) - arrs - where onRed red = - red { redLambda = Range.runRangeM $ Range.analyseLambda $ redLambda red } - onScan red = - red { scanLambda = Range.runRangeM $ Range.analyseLambda $ scanLambda red } instance (ASTLore lore, CanBeWise (Op lore)) => CanBeWise (SOAC lore) where type OpWithWisdom (SOAC lore) = SOAC (Wise lore) 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 @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Futhark.IR.SOACS.Simplify ( simplifySOACS , simplifyLambda @@ -16,6 +17,11 @@ , soacRules + , HasSOAC(..) + , simplifyKnownIterationSOAC + , removeReplicateMapping + , liftIdentityMapping + , SOACS ) where @@ -53,17 +59,8 @@ simpleSOACS = Simplify.bindableSimpleOps simplifySOAC simplifySOACS :: Prog SOACS -> PassM (Prog SOACS) -simplifySOACS = Simplify.simplifyProg simpleSOACS soacRules blockers - where blockers = Engine.noExtraHoistBlockers { Engine.getArraySizes = getShapeNames } - --- | Getting the roots of what to hoist, for now only variable --- names that represent shapes/sizes. -getShapeNames :: (LetDec lore ~ (VarWisdom, Type)) => - AST.Stm lore -> Names -getShapeNames bnd = - let tps1 = map patElemType $ patternElements $ stmPattern bnd - tps2 = map (snd . patElemDec) $ patternElements $ stmPattern bnd - in namesFromList $ subExpVars $ concatMap arrayDims (tps1 ++ tps2) +simplifySOACS = + Simplify.simplifyProg simpleSOACS soacRules Engine.noExtraHoistBlockers simplifyFun :: MonadFreshNames m => ST.SymbolTable (Wise SOACS) -> FunDef SOACS -> m (FunDef SOACS) @@ -71,7 +68,7 @@ Simplify.simplifyFun simpleSOACS soacRules Engine.noExtraHoistBlockers simplifyLambda :: (HasScope SOACS m, MonadFreshNames m) => - Lambda -> [Maybe VName] -> m Lambda + Lambda -> m Lambda simplifyLambda = Simplify.simplifyLambda simpleSOACS soacRules Engine.noExtraHoistBlockers @@ -93,12 +90,11 @@ outerdim' <- Engine.simplify outerdim (form', form_hoisted) <- simplifyStreamForm form arr' <- mapM Engine.simplify arr - (lam', lam_hoisted) <- Engine.simplifyLambda lam (map Just arr) + (lam', lam_hoisted) <- Engine.simplifyLambda lam return (Stream outerdim' form' lam' arr', form_hoisted <> lam_hoisted) where simplifyStreamForm (Parallel o comm lam0 acc) = do acc' <- mapM Engine.simplify acc - (lam0', hoisted) <- Engine.simplifyLambda lam0 $ - replicate (length $ lambdaParams lam0) Nothing + (lam0', hoisted) <- Engine.simplifyLambda lam0 return (Parallel o comm lam0' acc', hoisted) simplifyStreamForm (Sequential acc) = do acc' <- mapM Engine.simplify acc @@ -106,7 +102,7 @@ simplifySOAC (Scatter len lam ivs as) = do len' <- Engine.simplify len - (lam', hoisted) <- Engine.simplifyLambda lam $ map Just ivs + (lam', hoisted) <- Engine.simplifyLambda lam ivs' <- mapM Engine.simplify ivs as' <- mapM Engine.simplify as return (Scatter len' lam' ivs' as', hoisted) @@ -118,24 +114,24 @@ rf' <- Engine.simplify rf dests' <- Engine.simplify dests nes' <- mapM Engine.simplify nes - (op', hoisted) <- Engine.simplifyLambda op $ replicate (length $ lambdaParams op) Nothing + (op', hoisted) <- Engine.simplifyLambda op return (HistOp dests_w' rf' dests' nes' op', hoisted) imgs' <- mapM Engine.simplify imgs - (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun $ map Just imgs + (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun return (Hist w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted) simplifySOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do (scans', scans_hoisted) <- fmap unzip $ forM scans $ \(Scan lam nes) -> do - (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing + (lam', hoisted) <- Engine.simplifyLambda lam nes' <- Engine.simplify nes return (Scan lam' nes', hoisted) (reds', reds_hoisted) <- fmap unzip $ forM reds $ \(Reduce comm lam nes) -> do - (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing + (lam', hoisted) <- Engine.simplifyLambda lam nes' <- Engine.simplify nes return (Reduce comm lam' nes', hoisted) - (map_lam', map_lam_hoisted) <- Engine.simplifyLambda map_lam $ map Just arrs + (map_lam', map_lam_hoisted) <- Engine.simplifyLambda map_lam (,) <$> (Screma <$> Engine.simplify w <*> pure (ScremaForm scans' reds' map_lam') <*> @@ -169,6 +165,16 @@ soacRules :: RuleBook (Wise SOACS) soacRules = standardRules <> ruleBook topDownRules bottomUpRules +-- | Does this lore contain 'SOAC's in its t'Op's? A lore must be an +-- instance of this class for the simplification rules to work. +class HasSOAC lore where + asSOAC :: Op lore -> Maybe (SOAC lore) + soacOp :: SOAC lore -> Op lore + +instance HasSOAC (Wise SOACS) where + asSOAC = Just + soacOp = id + topDownRules :: [TopDownRule (Wise SOACS)] topDownRules = [RuleOp hoistCertificates, RuleOp removeReplicateMapping, @@ -198,7 +204,7 @@ hoistCertificates vtable pat aux soac | (soac', hoisted) <- runState (mapSOACM mapper soac) mempty, hoisted /= mempty = - Simplify $ certifying (hoisted <> stmAuxCerts aux) $ letBind pat $ Op soac' + Simplify $ auxing aux $ certifying hoisted $ letBind pat $ Op soac' where mapper = identitySOACMapper { mapOnSOACLambda = onLambda } onLambda lam = do stms' <- mapM onStm $ bodyStms $ lambdaBody lam @@ -215,9 +221,12 @@ hoistCertificates _ _ _ _ = Skip -liftIdentityMapping :: BottomUpRuleOp (Wise SOACS) -liftIdentityMapping (_, usages) pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form = do +liftIdentityMapping :: forall lore. + (Bindable lore, Simplify.SimplifiableLore lore, HasSOAC (Wise lore)) => + BottomUpRuleOp (Wise lore) +liftIdentityMapping (_, usages) pat aux op + | Just (Screma w form arrs :: SOAC (Wise lore)) <- asSOAC op, + Just fun <- isMapSOAC form = do let inputMap = M.fromList $ zip (map paramName $ lambdaParams fun) arrs free = freeIn $ lambdaBody fun rettype = lambdaReturnType fun @@ -253,11 +262,12 @@ , lambdaReturnType = rettype' } mapM_ (uncurry letBind) invariant - letBindNames (map patElemName pat') $ Op $ Screma w (mapSOAC fun') arrs + auxing aux $ + letBindNames (map patElemName pat') $ Op $ soacOp $ Screma w (mapSOAC fun') arrs liftIdentityMapping _ _ _ _ = Skip liftIdentityStreaming :: BottomUpRuleOp (Wise SOACS) -liftIdentityStreaming _ (Pattern [] pes) _ (Stream w form lam arrs) +liftIdentityStreaming _ (Pattern [] pes) aux (Stream w form lam arrs) | (variant_map, invariant_map) <- partitionEithers $ map isInvariantRes $ zip3 map_ts map_pes map_res, not $ null invariant_map = Simplify $ do @@ -269,7 +279,7 @@ lam' = lam { lambdaBody = (lambdaBody lam) { bodyResult = fold_res ++ variant_map_res } , lambdaReturnType = fold_ts ++ variant_map_ts } - letBind (Pattern [] $ fold_pes ++ variant_map_pes) $ + auxing aux $ letBind (Pattern [] $ fold_pes ++ variant_map_pes) $ Op $ Stream w form lam' arrs where num_folds = length $ getStreamAccums form (fold_pes, map_pes) = splitAt num_folds pes @@ -287,20 +297,22 @@ -- | Remove all arguments to the map that are simply replicates. -- These can be turned into free variables instead. -removeReplicateMapping :: TopDownRuleOp (Wise SOACS) -removeReplicateMapping vtable pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form, +removeReplicateMapping :: (Bindable lore, Simplify.SimplifiableLore lore, HasSOAC (Wise lore)) => + TopDownRuleOp (Wise lore) +removeReplicateMapping vtable pat aux op + | Just (Screma w form arrs) <- asSOAC op, + Just fun <- isMapSOAC form, Just (bnds, fun', arrs') <- removeReplicateInput vtable fun arrs = Simplify $ do forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e - letBind pat $ Op $ Screma w (mapSOAC fun') arrs' + auxing aux $ letBind pat $ Op $ soacOp $ Screma w (mapSOAC fun') arrs' removeReplicateMapping _ _ _ _ = Skip -- | Like 'removeReplicateMapping', but for 'Scatter'. removeReplicateWrite :: TopDownRuleOp (Wise SOACS) -removeReplicateWrite vtable pat _ (Scatter len lam ivs as) +removeReplicateWrite vtable pat aux (Scatter len lam ivs as) | Just (bnds, lam', ivs') <- removeReplicateInput vtable lam ivs = Simplify $ do forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e - letBind pat $ Op $ Scatter len lam' ivs' as + auxing aux $ letBind pat $ Op $ Scatter len lam' ivs' as removeReplicateWrite _ _ _ _ = Skip removeReplicateInput :: Aliased lore => @@ -335,19 +347,19 @@ -- | Remove inputs that are not used inside the SOAC. removeUnusedSOACInput :: TopDownRuleOp (Wise SOACS) -removeUnusedSOACInput _ pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) +removeUnusedSOACInput _ pat aux (Screma w (ScremaForm scan reduce map_lam) arrs) | (used,unused) <- partition usedInput params_and_arrs, not (null unused) = Simplify $ do let (used_params, used_arrs) = unzip used map_lam' = map_lam { lambdaParams = used_params } - letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') used_arrs + auxing aux $ letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') used_arrs where params_and_arrs = zip (lambdaParams map_lam) arrs used_in_body = freeIn $ lambdaBody map_lam usedInput (param, _) = paramName param `nameIn` used_in_body removeUnusedSOACInput _ _ _ _ = Skip removeDeadMapping :: BottomUpRuleOp (Wise SOACS) -removeDeadMapping (_, used) pat _ (Screma w form arrs) +removeDeadMapping (_, used) pat aux (Screma w form arrs) | Just fun <- isMapSOAC form = let ses = bodyResult $ lambdaBody fun isUsed (bindee, _, _) = (`UT.used` used) $ patElemName bindee @@ -357,12 +369,13 @@ , lambdaReturnType = ts' } in if pat /= Pattern [] pat' - then Simplify $ letBind (Pattern [] pat') $ Op $ Screma w (mapSOAC fun') arrs + then Simplify $ auxing aux $ + letBind (Pattern [] pat') $ Op $ Screma w (mapSOAC fun') arrs else Skip removeDeadMapping _ _ _ _ = Skip removeDuplicateMapOutput :: BottomUpRuleOp (Wise SOACS) -removeDuplicateMapOutput (_, used) pat _ (Screma w form arrs) +removeDuplicateMapOutput (_, used) pat aux (Screma w form arrs) | Just fun <- isMapSOAC form = let ses = bodyResult $ lambdaBody fun ts = lambdaReturnType fun @@ -376,7 +389,7 @@ pat' = Pattern [] pes' fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } , lambdaReturnType = ts' } - letBind pat' $ Op $ Screma w (mapSOAC fun') arrs + auxing aux $ letBind pat' $ Op $ Screma w (mapSOAC fun') arrs forM_ copies $ \(from,to) -> if UT.isConsumed (patElemName to) used then letBind (Pattern [] [to]) $ BasicOp $ Copy $ patElemName from @@ -479,7 +492,7 @@ -- | If we are writing to an array that is never used, get rid of it. removeDeadWrite :: BottomUpRuleOp (Wise SOACS) -removeDeadWrite (_, used) pat _ (Scatter w fun arrs dests) = +removeDeadWrite (_, used) pat aux (Scatter w fun arrs dests) = let (i_ses, v_ses) = splitAt (length dests) $ bodyResult $ lambdaBody fun (i_ts, v_ts) = splitAt (length dests) $ lambdaReturnType fun isUsed (bindee, _, _, _, _, _) = (`UT.used` used) $ patElemName bindee @@ -490,7 +503,8 @@ , lambdaReturnType = i_ts' ++ v_ts' } in if pat /= Pattern [] pat' - then Simplify $ letBind (Pattern [] pat') $ Op $ Scatter w fun' arrs dests' + then Simplify $ auxing aux $ + letBind (Pattern [] pat') $ Op $ Scatter w fun' arrs dests' else Skip removeDeadWrite _ _ _ _ = Skip @@ -517,7 +531,7 @@ certifying (mconcat css) $ letBind pat $ Op $ Scatter w' fun' (concat xivs) $ map (incWrites r) dests where sizeOf :: VName -> Maybe SubExp - sizeOf x = arraySize 0 . ST.entryType <$> ST.lookup x vtable + sizeOf x = arraySize 0 . typeOf <$> ST.lookup x vtable mix = concat . transpose incWrites r (w, n, a) = (w, n*r, a) -- ToDO: is it (n*r) or (n+r-1)?? isConcat v = case ST.lookupExp v vtable of @@ -546,11 +560,26 @@ simplifyClosedFormReduce _ _ _ _ = Skip -- For now we just remove singleton SOACs. -simplifyKnownIterationSOAC :: TopDownRuleOp (Wise SOACS) -simplifyKnownIterationSOAC _ pat _ (Screma (Constant k) - (ScremaForm scans reds map_lam) - arrs) - | oneIsh k = Simplify $ do +simplifyKnownIterationSOAC :: (Bindable lore, Simplify.SimplifiableLore lore, HasSOAC (Wise lore)) => + TopDownRuleOp (Wise lore) +simplifyKnownIterationSOAC _ pat _ op + | Just (Screma (Constant k) (ScremaForm scans reds map_lam) arrs) <- asSOAC op, + oneIsh k = Simplify $ do + + let (Reduce _ red_lam red_nes) = singleReduce reds + (Scan scan_lam scan_nes) = singleScan scans + (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ + patternElements pat + bindMapParam p a = do + a_t <- lookupType a + letBindNames [paramName p] $ + BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0::Int32)] + bindArrayResult pe se = + letBindNames [patElemName pe] $ + BasicOp $ ArrayLit [se] $ rowType $ patElemType pe + bindResult pe se = + letBindNames [patElemName pe] $ BasicOp $ SubExp se + zipWithM_ bindMapParam (lambdaParams map_lam) arrs (to_scan, to_red, map_res) <- splitAt3 (length scan_nes) (length red_nes) <$> bodyBind (lambdaBody map_lam) @@ -561,22 +590,9 @@ zipWithM_ bindResult red_pes red_res zipWithM_ bindArrayResult map_pes map_res - where (Reduce _ red_lam red_nes) = singleReduce reds - (Scan scan_lam scan_nes) = singleScan scans - (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ - patternElements pat - bindMapParam p a = do - a_t <- lookupType a - letBindNames [paramName p] $ - BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0::Int32)] - bindArrayResult pe se = - letBindNames [patElemName pe] $ - BasicOp $ ArrayLit [se] $ rowType $ patElemType pe - bindResult pe se = - letBindNames [patElemName pe] $ BasicOp $ SubExp se - -simplifyKnownIterationSOAC _ pat _ (Stream (Constant k) form fold_lam arrs) - | oneIsh k = Simplify $ do +simplifyKnownIterationSOAC _ pat _ op + | Just (Stream (Constant k) form fold_lam arrs) <- asSOAC op, + oneIsh k = Simplify $ do let nes = getStreamAccums form (chunk_param, acc_params, slice_params) = partitionChunkedFoldParameters (length nes) (lambdaParams fold_lam) @@ -649,7 +665,8 @@ mkBody (fmap onStm stms) res where onStm (Let pat aux e) = let (cs', e') = onExp (stmAuxCerts aux) e - in certify cs' $ mkLet (patternContextIdents pat) (patternValueIdents pat) e' + in certify cs' $ + mkLet' (patternContextIdents pat) (patternValueIdents pat) aux e' onExp cs e | Just op <- isArrayOp cs e, Just op' <- M.lookup op substs = @@ -676,7 +693,7 @@ -- complex situations (rotate or whatnot), consider turning it into a -- separate compiler pass instead. simplifyMapIota :: TopDownRuleOp (Wise SOACS) -simplifyMapIota vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) +simplifyMapIota vtable pat aux (Screma w (ScremaForm scan reduce map_lam) arrs) | Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs), indexings <- filter (indexesWith (paramName p)) $ map snd $ S.toList $ arrayOps $ lambdaBody map_lam, @@ -690,7 +707,9 @@ , lambdaBody = replaceArrayOps substs $ lambdaBody map_lam } - letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) + + auxing aux $ + letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) where isIota (_, arr) = case ST.lookupBasicOp arr vtable of Just (Iota _ (Constant o) (Constant s) _, _) -> zeroIsh o && oneIsh s @@ -723,7 +742,7 @@ -- corresponding to that transformation performed on the rows of the -- full array. moveTransformToInput :: TopDownRuleOp (Wise SOACS) -moveTransformToInput vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) +moveTransformToInput vtable pat aux (Screma w (ScremaForm scan reduce map_lam) arrs) | ops <- map snd $ filter arrayIsMapParam $ S.toList $ arrayOps $ lambdaBody map_lam, not $ null ops = Simplify $ do (more_arrs, more_params, replacements) <- @@ -737,7 +756,8 @@ lambdaBody map_lam } - letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) + auxing aux $ + letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) where map_param_names = map paramName (lambdaParams map_lam) topLevelPattern = (`elem` fmap stmPattern (bodyStms (lambdaBody map_lam))) diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -68,16 +68,12 @@ import Futhark.Transform.Substitute import Futhark.Transform.Rename import Futhark.Optimise.Simplify.Lore -import Futhark.IR.Ranges - (Ranges, removeLambdaRanges, removeStmRanges, mkBodyRanges) -import Futhark.IR.Prop.Ranges import Futhark.IR.Prop.Aliases import Futhark.IR.Aliases (Aliases, removeLambdaAliases, removeStmAliases) import Futhark.IR.Mem import qualified Futhark.TypeCheck as TC import Futhark.Analysis.Metrics -import qualified Futhark.Analysis.Range as Range import Futhark.Util (maybeNth, chunks) import Futhark.Optimise.Simplify.Rule import qualified Futhark.Optimise.Simplify.Engine as Engine @@ -266,18 +262,6 @@ removeKernelBodyAliases (KernelBody (_, dec) stms res) = KernelBody dec (fmap removeStmAliases stms) res -addKernelBodyRanges :: (ASTLore lore, CanBeRanged (Op lore)) => - KernelBody lore -> Range.RangeM (KernelBody (Ranges lore)) -addKernelBodyRanges (KernelBody dec stms res) = - Range.analyseStms stms $ \stms' -> do - let dec' = (mkBodyRanges stms $ map kernelResultSubExp res, dec) - return $ KernelBody dec' stms' res - -removeKernelBodyRanges :: CanBeRanged (Op lore) => - KernelBody (Ranges lore) -> KernelBody lore -removeKernelBodyRanges (KernelBody (_, dec) stms res) = - KernelBody dec (fmap removeStmRanges stms) res - removeKernelBodyWisdom :: CanBeWise (Op lore) => KernelBody (Wise lore) -> KernelBody lore removeKernelBodyWisdom (KernelBody dec stms res) = @@ -753,21 +737,6 @@ ppr shape <> PP.comma ppr op -instance (ASTLore inner, ASTConstraints lvl) => - RangedOp (SegOp lvl inner) where - opRanges op = replicate (length $ segOpType op) unknownRange - -instance (ASTLore lore, CanBeRanged (Op lore), ASTConstraints lvl) => - CanBeRanged (SegOp lvl lore) where - type OpWithRanges (SegOp lvl lore) = SegOp lvl (Ranges lore) - - removeOpRanges = runIdentity . mapSegOpM remove - where remove = SegOpMapper return (return . removeLambdaRanges) - (return . removeKernelBodyRanges) return return - addOpRanges = Range.runRangeM . mapSegOpM add - where add = SegOpMapper return Range.analyseLambda - addKernelBodyRanges return return - instance (ASTLore lore, ASTLore (Aliases lore), CanBeAliased (Op lore), ASTConstraints lvl) => CanBeAliased (SegOp lvl lore) where @@ -901,16 +870,21 @@ return (mkWiseKernelBody () body_stms body_res, hoisted) - where scope_vtable = ST.fromScope $ scopeOfSegSpace space + where scope_vtable = segSpaceSymbolTable space bound_here = namesFromList $ M.keys $ scopeOfSegSpace space +segSpaceSymbolTable :: ASTLore lore => SegSpace -> ST.SymbolTable lore +segSpaceSymbolTable (SegSpace flat gtids_and_dims) = + foldl' f (ST.fromScope $ M.singleton flat $ IndexName Int32) gtids_and_dims + where f vtable (gtid, dim) = ST.insertLoopVar gtid Int32 dim vtable + simplifySegBinOp :: Engine.SimplifiableLore lore => SegBinOp lore -> Engine.SimpleM lore (SegBinOp (Wise lore), Stms (Wise lore)) simplifySegBinOp (SegBinOp comm lam nes shape) = do (lam', hoisted) <- Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ - Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing + Engine.simplifyLambda lam shape' <- Engine.simplify shape nes' <- mapM Engine.simplify nes return (SegBinOp comm lam' nes' shape', hoisted) @@ -962,8 +936,7 @@ (lam', op_hoisted) <- Engine.localVtable (<>scope_vtable) $ Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ - Engine.simplifyLambda lam $ - replicate (length nes * 2) Nothing + Engine.simplifyLambda lam return (HistOp w' rf' arrs' nes' dims' lam', op_hoisted) diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs --- a/src/Futhark/IR/SeqMem.hs +++ b/src/Futhark/IR/SeqMem.hs @@ -63,6 +63,7 @@ matchPattern = matchPatternToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType + matchLoopResult = matchLoopResultMem instance BinderOps SeqMem where mkExpDecB _ _ = return () @@ -75,9 +76,8 @@ mkLetNamesB = mkLetNamesB'' simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) -simplifyProg = - simplifyProgGeneric $ const $ return ((), mempty) +simplifyProg = simplifyProgGeneric simpleSeqMem simpleSeqMem :: Engine.SimpleOps SeqMem simpleSeqMem = - simpleGeneric $ const $ return ((), mempty) + simpleGeneric (const mempty) $ const $ return ((), mempty) diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs --- a/src/Futhark/IR/Syntax.hs +++ b/src/Futhark/IR/Syntax.hs @@ -115,6 +115,7 @@ , Attrs(..) , oneAttr , inAttrs + , withoutAttrs -- * Abstract syntax tree , Ident (..) @@ -173,7 +174,9 @@ import Futhark.IR.Syntax.Core -- | A single attribute. -newtype Attr = AttrAtom Name +data Attr + = AttrAtom Name + | AttrComp Name [Attr] deriving (Ord, Show, Eq) instance IsString Attr where @@ -192,6 +195,10 @@ inAttrs :: Attr -> Attrs -> Bool inAttrs attr (Attrs attrs) = attr `S.member` attrs +-- | @x `withoutAttrs` y@ gives @x@ except for any attributes also in @y@. +withoutAttrs :: Attrs -> Attrs -> Attrs +withoutAttrs (Attrs x) (Attrs y) = Attrs $ x `S.difference` y + -- | A type alias for namespace control. type PatElem lore = PatElemT (LetDec lore) @@ -379,14 +386,6 @@ | Replicate Shape SubExp -- ^ @replicate([3][2],1) = [[1,1], [1,1], [1,1]]@ - | Repeat [Shape] Shape VName - -- ^ Repeat each dimension of the input array some number of times, - -- given by the corresponding shape. For an array of rank @k@, the - -- list must contain @k@ shapes. A shape may be empty (in which - -- case the dimension is not repeated, but it is still present). - -- The last shape indicates the amount of extra innermost - -- dimensions. All other extra dimensions are added *before* the original dimension. - | Scratch PrimType [SubExp] -- ^ Create array of given type and shape, with undefined elements. @@ -427,13 +426,6 @@ deriving instance Decorations lore => Show (ExpT lore) deriving instance Decorations lore => Ord (ExpT lore) --- | Whether something is safe or unsafe (mostly function calls, and --- in the context of whether operations are dynamically checked). --- When we inline an 'Unsafe' function, we remove all safety checks in --- its body. The 'Ord' instance picks 'Unsafe' as being less than --- 'Safe'. -data Safety = Unsafe | Safe deriving (Eq, Ord, Show) - -- | For-loop or while-loop? data LoopForm lore = ForLoop VName IntType SubExp [(LParam lore,VName)] | WhileLoop VName @@ -456,7 +448,7 @@ -- ^ A branch where the "true" case is what we are -- actually interested in, and the "false" case is only -- present as a fallback for when the true case cannot - -- be safely evaluated. the compiler is permitted to + -- be safely evaluated. The compiler is permitted to -- optimise away the branch if the true case contains -- only safe statements. | IfEquiv @@ -492,6 +484,7 @@ data FunDef lore = FunDef { funDefEntryPoint :: Maybe EntryPoint -- ^ Contains a value if this function is -- an entry point. + , funDefAttrs :: Attrs , funDefName :: Name , funDefRetType :: [RetType lore] , funDefParams :: [FParam lore] 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 @@ -49,6 +49,7 @@ , sliceDims , unitSlice , fixSlice + , sliceSlice , PatElemT (..) ) where @@ -75,6 +76,10 @@ | Free a deriving (Eq, Ord, Show) +instance Functor Ext where + fmap _ (Ext i) = Ext i + fmap f (Free a) = Free $ f a + -- | The size of this dimension. type ExtSize = Ext SubExp @@ -162,7 +167,7 @@ data NoUniqueness = NoUniqueness deriving (Eq, Ord, Show) --- | An Futhark type is either an array or an element type. When +-- | A Futhark type is either an array or an element type. When -- comparing types for equality with '==', shapes must match. data TypeBase shape u = Prim PrimType | Array PrimType shape u @@ -297,6 +302,17 @@ fixSlice (DimSlice orig_k _ orig_s:mis') (i:is') = (orig_k+i*orig_s) : fixSlice mis' is' fixSlice _ _ = [] + +-- | Further slice the 'DimSlice's of a slice. The number of slices +-- must equal the length of 'sliceDims' for the slice. +sliceSlice :: Num d => Slice d -> Slice d -> Slice d +sliceSlice (DimFix j:js') is' = + DimFix j : sliceSlice js' is' +sliceSlice (DimSlice j _ s:js') (DimFix i:is') = + DimFix (j + (i*s)) : sliceSlice js' is' +sliceSlice (DimSlice j _ s0:js') (DimSlice i n s1:is') = + DimSlice (j+(s0*i)) n (s0*s1) : sliceSlice js' is' +sliceSlice _ _ = [] -- | An element of a pattern - consisting of a name and an addditional -- parametric decoration. This decoration is what is expected to 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 @@ -110,9 +110,6 @@ BasicOp <$> (Iota <$> mapOnSubExp tv n <*> mapOnSubExp tv x <*> mapOnSubExp tv s <*> pure et) mapExpM tv (BasicOp (Replicate shape vexp)) = BasicOp <$> (Replicate <$> mapOnShape tv shape <*> mapOnSubExp tv vexp) -mapExpM tv (BasicOp (Repeat shapes innershape v)) = - BasicOp <$> (Repeat <$> mapM (mapOnShape tv) shapes <*> - mapOnShape tv innershape <*> mapOnVName tv v) mapExpM tv (BasicOp (Scratch t shape)) = BasicOp <$> (Scratch t <$> mapM (mapOnSubExp tv) shape) mapExpM tv (BasicOp (Reshape shape arrexp)) = @@ -246,8 +243,6 @@ walkOnSubExp tv n >> walkOnSubExp tv x >> walkOnSubExp tv s walkExpM tv (BasicOp (Replicate shape vexp)) = walkOnShape tv shape >> walkOnSubExp tv vexp -walkExpM tv (BasicOp (Repeat shapes innershape v)) = - mapM_ (walkOnShape tv) shapes >> walkOnShape tv innershape >> walkOnVName tv v walkExpM tv (BasicOp (Scratch _ shape)) = mapM_ (walkOnSubExp tv) shape walkExpM tv (BasicOp (Reshape shape arrexp)) = diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -25,8 +25,6 @@ import Futhark.Transform.Rename as I import Futhark.MonadFreshNames import Futhark.Tools -import Futhark.IR.Prop.Aliases -import qualified Futhark.Analysis.Alias as Alias import Futhark.Util (splitAt3) import Futhark.Internalise.Monad as I @@ -50,6 +48,13 @@ runInternaliseM always_safe (internaliseValBinds prog_decs'') I.renameProg $ I.Prog consts funs +internaliseAttr :: E.AttrInfo -> Attr +internaliseAttr (E.AttrAtom v) = I.AttrAtom v +internaliseAttr (E.AttrComp f attrs) = I.AttrComp f $ map internaliseAttr attrs + +internaliseAttrs :: [E.AttrInfo] -> Attrs +internaliseAttrs = mconcat . map (oneAttr . internaliseAttr) + internaliseValBinds :: [E.ValBind] -> InternaliseM () internaliseValBinds = mapM_ internaliseValBind @@ -66,7 +71,7 @@ Nothing -> return $ nameFromString $ pretty ofname internaliseValBind :: E.ValBind -> InternaliseM () -internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ loc) = do +internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ attrs loc) = do localConstsScope $ bindingParams tparams params $ \shapeparams params' -> do rettype_bad <- internaliseReturnType rettype let rettype' = zeroExts rettype_bad @@ -84,7 +89,7 @@ typeExpForError dt Nothing -> return $ errorMsg ["Function return value does not match shape of declared return type."] internaliseBody body >>= - ensureResultExtShape asserting msg loc (map I.fromDecl rettype') + ensureResultExtShape msg loc (map I.fromDecl rettype') constants <- allConsts let free_in_fun = freeIn body' @@ -100,7 +105,8 @@ free_params = nub $ free_shape_params ++ used_free_params all_params = free_params ++ shapeparams ++ concat params' - let fd = I.FunDef Nothing fname' rettype' all_params body' + let fd = I.FunDef Nothing (internaliseAttrs attrs) fname' + rettype' all_params body' if null params' then bindConstant fname fd @@ -151,7 +157,8 @@ mapM allDimsFreshInPat pats <*> pure loc generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM () -generateEntryPoint (E.EntryPoint e_paramts e_rettype) (E.ValBind _ ofname _ (Info (rettype, _)) _ params _ _ loc) = localConstsScope $ do +generateEntryPoint (E.EntryPoint e_paramts e_rettype) vb = localConstsScope $ do + let (E.ValBind _ ofname _ (Info (rettype, _)) _ params _ _ attrs loc) = vb -- We replace all shape annotations, so there should be no constant -- parameters here. params_fresh <- mapM allDimsFreshInPat params @@ -176,7 +183,8 @@ resultBodyM (ctx ++ vals) addFunDef $ - I.FunDef (Just entry') (baseName ofname) + I.FunDef (Just entry') (internaliseAttrs attrs) + (baseName ofname) (concat entry_rettype) (shapeparams ++ concat params') entry_body @@ -191,7 +199,7 @@ (Just ts, Just (E.TETuple e_ts _)) -> concatMap entryPointType $ zip (zipWith E.EntryType ts (map Just e_ts)) crets - (Just ts, _) -> + (Just ts, Nothing) -> concatMap entryPointType $ zip (map (`E.EntryType` Nothing) ts) crets _ -> @@ -214,7 +222,7 @@ -- | We remove dimension arguments such that we hopefully end -- up with a simpler type name for the entry point. The - -- intend is that if an entry point uses a type 'nasty [w] [h]', + -- intent is that if an entry point uses a type 'nasty [w] [h]', -- then we should turn that into an opaque type just called -- 'nasty'. Also, we try to give arrays of opaques a nicer name. typeExpOpaqueName (TEApply te TypeArgExpDim{} _) = @@ -336,7 +344,7 @@ e':_ -> mapM subExpType e' let arraylit ks rt = do - ks' <- mapM (ensureShape asserting + ks' <- mapM (ensureShape "shape of element differs from shape of first element" loc rt "elem_reshaped") ks return $ I.BasicOp $ I.ArrayLit ks' rt @@ -455,21 +463,18 @@ step_invalid <- letSubExp "step_invalid" $ I.BasicOp $ I.BinOp I.LogOr step_wrong_dir step_zero - cs <- assertingOne $ do - invalid <- letSubExp "range_invalid" $ - I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid - valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid - - letExp "range_valid_c" $ - I.BasicOp $ I.Assert valid errmsg (loc, mempty) + invalid <- letSubExp "range_invalid" $ + I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid + valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid + cs <- assert "range_valid_c" valid errmsg loc step_i32 <- asIntS Int32 step pos_step <- letSubExp "pos_step" $ I.BasicOp $ I.BinOp (Mul Int32 I.OverflowWrap) step_i32 step_sign_i32 num_elems <- certifying cs $ - letSubExp "num_elems" =<< - eDivRoundingUp Int32 (eSubExp distance) (eSubExp pos_step) + letSubExp "num_elems" $ + I.BasicOp $ I.BinOp (SDivUp Int32 I.Unsafe) distance pos_step se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it) bindExtSizes (E.toStruct ret) retext [se] @@ -478,16 +483,17 @@ internaliseExp desc (E.Ascript e _ _) = internaliseExp desc e -internaliseExp desc (E.Coerce e (TypeDecl dt (Info et)) _ loc) = do - es <- internaliseExp desc e +internaliseExp desc (E.Coerce e (TypeDecl dt (Info et)) (Info ret, Info retext) loc) = do + ses <- internaliseExp desc e ts <- internaliseReturnType et dt' <- typeExpForError dt - forM (zip es ts) $ \(e',t') -> do + bindExtSizes (E.toStruct ret) retext ses + forM (zip ses ts) $ \(e',t') -> do dims <- arrayDims <$> subExpType e' let parts = ["Value of (core language) shape ("] ++ intersperse ", " (map ErrorInt32 dims) ++ [") cannot match shape of type `"] ++ dt' ++ ["`."] - ensureExtShape asserting (errorMsg parts) loc (I.fromDecl t') desc e' + ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e' internaliseExp desc (E.Negate e _) = do e' <- internaliseExp1 "negate_arg" e @@ -535,7 +541,8 @@ return ses internaliseExp desc (E.LetFun ofname (tparams, params, retdecl, Info rettype, body) letbody _ loc) = do - internaliseValBind $ E.ValBind Nothing ofname retdecl (Info (rettype, [])) tparams params body Nothing loc + internaliseValBind $ + E.ValBind Nothing ofname retdecl (Info (rettype, [])) tparams params body Nothing mempty loc internaliseExp desc letbody internaliseExp desc (E.DoLoop sparams mergepat mergeexp form loopbody (Info (ret, retext)) loc) = do @@ -566,7 +573,7 @@ loopbody'' <- localScope (scopeOfFParams $ map fst merge) $ inScopeOf form' $ insertStmsM $ resultBodyM - =<< ensureArgShapes asserting + =<< ensureArgShapes "shape of loop result does not match shapes in loop parameter" loc (map (I.paramName . fst) ctxmerge) merge_ts =<< bodyBind loopbody' @@ -696,7 +703,7 @@ sname_t <- lookupType sname let full_slice = fullSlice sname_t idxs' rowtype = sname_t `setArrayDims` sliceDims full_slice - ve'' <- ensureShape asserting "shape of value does not match shape of source array" + ve'' <- ensureShape "shape of value does not match shape of source array" loc rowtype "lw_val_correct_shape" ve' letInPlace desc sname full_slice $ BasicOp $ SubExp ve'' certifying cs $ map I.Var <$> zipWithM comb srcs ves @@ -715,23 +722,18 @@ return $ bef ++ src'' ++ aft replace _ _ ve' _ = return ve' -internaliseExp desc (E.Unsafe e _) = - local mkUnsafe $ internaliseExp desc e - where mkUnsafe env | envSafe env = env - | otherwise = env { envDoBoundsChecks = False } - -internaliseExp desc (E.Attr (AttrInfo attr) e _) = +internaliseExp desc (E.Attr attr e _) = local f $ internaliseExp desc e - where f env | attr == "unsafe", + where attrs = oneAttr $ internaliseAttr attr + f env | "unsafe" `inAttrs` attrs, not $ envSafe env = env { envDoBoundsChecks = False } | otherwise = - env { envAttrs = oneAttr (AttrAtom attr) <> envAttrs env } + env { envAttrs = envAttrs env <> attrs } internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do e1' <- internaliseExp1 "assert_cond" e1 - c <- assertingOne $ letExp "assert_c" $ - I.BasicOp $ I.Assert e1' (errorMsg [ErrorString check]) (loc, mempty) + c <- assert "assert_c" e1' (errorMsg [ErrorString check]) loc -- Make sure there are some bindings to certify. certifying c $ mapM rebind =<< internaliseExp desc e2 where rebind v = do @@ -952,12 +954,11 @@ -> InternaliseM ([I.DimIndex SubExp], Certificates) internaliseSlice loc dims idxs = do (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs - c <- assertingOne $ do - ok <- letSubExp "index_ok" =<< eAll oks - let msg = errorMsg $ ["Index ["] ++ intercalate [", "] parts ++ - ["] out of bounds for array of shape ["] ++ - intersperse "][" (map ErrorInt32 $ take (length idxs) dims) ++ ["]."] - letExp "index_certs" $ I.BasicOp $ I.Assert ok msg (loc, mempty) + ok <- letSubExp "index_ok" =<< eAll oks + let msg = errorMsg $ ["Index ["] ++ intercalate [", "] parts ++ + ["] out of bounds for array of shape ["] ++ + intersperse "][" (map ErrorInt32 $ take (length idxs) dims) ++ ["]."] + c <- assert "index_certs" ok msg loc return (idxs', c) internaliseDimIndex :: SubExp -> E.DimIndex @@ -970,6 +971,17 @@ I.CmpOp (I.CmpSlt I.Int32) i' w ok <- letSubExp "bounds_check" =<< eBinOp I.LogAnd (pure lowerBound) (pure upperBound) return (I.DimFix i', ok, [ErrorInt32 i']) + +-- Special-case an important common case that otherwise leads to horrible code. +internaliseDimIndex w (E.DimSlice Nothing Nothing + (Just (E.Negate (E.IntLit 1 _ _) _))) = do + w_minus_1 <- letSubExp "w_minus_1" $ + BasicOp $ I.BinOp (Sub Int32 I.OverflowWrap) w one + return (I.DimSlice w_minus_1 w $ intConst Int32 (-1), + constant True, + mempty) + where one = constant (1::Int32) + internaliseDimIndex w (E.DimSlice i j s) = do s' <- maybe (return one) (fmap fst . internaliseDimExp "s") s s_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum Int32) s' @@ -987,8 +999,9 @@ -- Something like a division-rounding-up, but accomodating negative -- operands. let divRounding x y = - eBinOp (SQuot Int32) (eBinOp (Add Int32 I.OverflowWrap) x - (eBinOp (Sub Int32 I.OverflowWrap) y (eSignum $ toExp s'))) y + eBinOp (SQuot Int32 Unsafe) + (eBinOp (Add Int32 I.OverflowWrap) x + (eBinOp (Sub Int32 I.OverflowWrap) y (eSignum $ toExp s'))) y n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s') -- Bounds checks depend on whether we are slicing forwards or @@ -1035,7 +1048,7 @@ ErrorInt32 j'] ++ maybe mempty (const [":", ErrorInt32 s']) s (_, Nothing, Nothing) -> - [ErrorInt32 i'] + [ErrorInt32 i', ":"] return (I.DimSlice i' n s', ok_or_empty, parts) where zero = constant (0::Int32) negone = constant (-1::Int32) @@ -1050,7 +1063,7 @@ nes <- internaliseExp (what++"_ne") ne nes' <- forM (zip nes arrs) $ \(ne', arr') -> do rowtype <- I.stripArray 1 <$> lookupType arr' - ensureShape asserting + ensureShape "Row shape of input array does not match shape of neutral element" loc rowtype (what++"_ne_right_shape") ne' nests <- mapM I.subExpType nes' @@ -1073,7 +1086,7 @@ -- reshape neutral element to have same size as the destination array ne_shp <- forM (zip ne' hist') $ \(n, h) -> do rowtype <- I.stripArray 1 <$> lookupType h - ensureShape asserting + ensureShape "Row shape of destination array does not match shape of neutral element" loc rowtype "hist_ne_right_shape" n ne_ts <- mapM I.subExpType ne_shp @@ -1088,7 +1101,7 @@ rettype = I.Prim int32 : ne_ts body = mkBody mempty $ map (I.Var . paramName) params body' <- localScope (scopeOfLParams params) $ - ensureResultShape asserting + ensureResultShape "Row shape of value array does not match row shape of hist target" (srclocOf img) rettype body @@ -1101,9 +1114,8 @@ b_shape <- I.arrayShape <$> lookupType buckets' let b_w = shapeSize 0 b_shape cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int32) b_w w_img - c <- assertingOne $ - letExp "bucket_cert" $ I.BasicOp $ - I.Assert cmp "length of index and value array does not match" (loc, mempty) + c <- assert "bucket_cert" cmp + "length of index and value array does not match" loc buckets'' <- certifying c $ letExp (baseString buckets') $ I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets' @@ -1138,40 +1150,36 @@ letBindNames [I.paramName p] $ I.BasicOp $ I.Scratch (I.elemType $ I.paramType p) $ I.arrayDims $ I.paramType p - accs <- bodyBind =<< renameBody lam_body + nes <- bodyBind =<< renameBody lam_body - acctps <- mapM I.subExpType accs + nes_ts <- mapM I.subExpType nes outsz <- arraysSize 0 <$> mapM lookupType arrs - let acc_arr_tps = [ I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- acctps ] - lam0' <- internaliseFoldLambda internaliseLambda lam0 acctps acc_arr_tps - let lam0_acc_params = take (length accs) $ I.lambdaParams lam0' - acc_params <- forM lam0_acc_params $ \p -> do + let acc_arr_tps = [ I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- nes_ts ] + lam0' <- internaliseFoldLambda internaliseLambda lam0 nes_ts acc_arr_tps + + let lam0_acc_params = take (length nes) $ I.lambdaParams lam0' + lam_acc_params <- forM lam0_acc_params $ \p -> do name <- newVName $ baseString $ I.paramName p return p { I.paramName = name } + -- Make sure the chunk size parameter comes first. + let lam_params' = chunk_param : lam_acc_params ++ lam_val_params + body_with_lam0 <- - ensureResultShape asserting "shape of result does not match shape of initial value" - (srclocOf lam0) acctps <=< insertStmsM $ do + ensureResultShape "shape of result does not match shape of initial value" + (srclocOf lam0) nes_ts <=< insertStmsM $ localScope (scopeOfLParams lam_params') $ do lam_res <- bodyBind lam_body - - let consumed = consumedByLambda $ Alias.analyseLambda lam0' - copyIfConsumed p (I.Var v) - | I.paramName p `nameIn` consumed = - letSubExp "acc_copy" $ I.BasicOp $ I.Copy v - copyIfConsumed _ x = return x - - accs' <- zipWithM copyIfConsumed (I.lambdaParams lam0') accs - lam_res' <- ensureArgShapes asserting + lam_res' <- ensureArgShapes "shape of chunk function result does not match shape of initial value" (srclocOf lam) [] (map I.typeOf $ I.lambdaParams lam0') lam_res - new_lam_res <- eLambda lam0' $ map eSubExp $ accs' ++ lam_res' + new_lam_res <- eLambda lam0' $ map eSubExp $ + map (I.Var . paramName) lam_acc_params ++ lam_res' return $ resultBody new_lam_res - -- Make sure the chunk size parameter comes first. - let form = I.Parallel o comm lam0' accs - lam' = I.Lambda { lambdaParams = chunk_param : acc_params ++ lam_val_params + let form = I.Parallel o comm lam0' nes + lam' = I.Lambda { lambdaParams = lam_params' , lambdaBody = body_with_lam0 - , lambdaReturnType = acctps } + , lambdaReturnType = nes_ts } w <- arraysSize 0 <$> mapM lookupType arrs letTupExp' desc $ I.Op $ I.Stream w form lam' arrs @@ -1209,23 +1217,19 @@ -> InternaliseM a -> InternaliseM a certifyingNonzero loc t x m = do - c <- assertingOne $ do - zero <- letSubExp "zero" $ I.BasicOp $ - CmpOp (CmpEq (IntType t)) x (intConst t 0) - nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero - letExp "nonzero_cert" $ I.BasicOp $ - I.Assert nonzero "division by zero" (loc, mempty) + zero <- letSubExp "zero" $ I.BasicOp $ + CmpOp (CmpEq (IntType t)) x (intConst t 0) + nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero + c <- assert "nonzero_cert" nonzero "division by zero" loc certifying c m certifyingNonnegative :: SrcLoc -> IntType -> SubExp -> InternaliseM a -> InternaliseM a certifyingNonnegative loc t x m = do - c <- assertingOne $ do - nonnegative <- letSubExp "nonnegative" $ I.BasicOp $ - CmpOp (CmpSle t) (intConst t 0) x - letExp "nonzero_cert" $ I.BasicOp $ - I.Assert nonnegative "negative exponent" (loc, mempty) + nonnegative <- letSubExp "nonnegative" $ I.BasicOp $ + CmpOp (CmpSle t) (intConst t 0) x + c <- assert "nonzero_cert" nonnegative "negative exponent" loc certifying c m internaliseBinOp :: SrcLoc -> String @@ -1254,10 +1258,10 @@ simpleBinOp desc (I.FMul t) x y internaliseBinOp loc desc E.Divide x y (E.Signed t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.SDiv t) x y + simpleBinOp desc (I.SDiv t I.Unsafe) x y internaliseBinOp loc desc E.Divide x y (E.Unsigned t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.UDiv t) x y + simpleBinOp desc (I.UDiv t I.Unsafe) x y internaliseBinOp _ desc E.Divide x y (E.FloatType t) _ = simpleBinOp desc (I.FDiv t) x y internaliseBinOp _ desc E.Pow x y (E.FloatType t) _ = @@ -1269,24 +1273,24 @@ simpleBinOp desc (I.Pow t) x y internaliseBinOp loc desc E.Mod x y (E.Signed t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.SMod t) x y + simpleBinOp desc (I.SMod t I.Unsafe) x y internaliseBinOp loc desc E.Mod x y (E.Unsigned t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.UMod t) x y + simpleBinOp desc (I.UMod t I.Unsafe) x y internaliseBinOp _ desc E.Mod x y (E.FloatType t) _ = simpleBinOp desc (I.FMod t) x y internaliseBinOp loc desc E.Quot x y (E.Signed t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.SQuot t) x y + simpleBinOp desc (I.SQuot t I.Unsafe) x y internaliseBinOp loc desc E.Quot x y (E.Unsigned t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.UDiv t) x y + simpleBinOp desc (I.UDiv t I.Unsafe) x y internaliseBinOp loc desc E.Rem x y (E.Signed t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.SRem t) x y + simpleBinOp desc (I.SRem t I.Unsafe) x y internaliseBinOp loc desc E.Rem x y (E.Unsigned t) _ = certifyingNonzero loc t y $ - simpleBinOp desc (I.UMod t) x y + simpleBinOp desc (I.UMod t I.Unsafe) x y internaliseBinOp _ desc E.ShiftR x y (E.Signed t) _ = simpleBinOp desc (I.AShr t) x y internaliseBinOp _ desc E.ShiftR x y (E.Unsigned t) _ = @@ -1569,12 +1573,13 @@ -- The unflattened dimension needs to have the same number of elements -- as the original dimension. old_dim <- I.arraysSize 0 <$> mapM lookupType arrs - dim_ok <- assertingOne $ letExp "dim_ok" =<< - eAssert (eCmpOp (I.CmpEq I.int32) - (eBinOp (I.Mul Int32 I.OverflowUndef) (eSubExp n') (eSubExp m')) - (eSubExp old_dim)) - "new shape has different number of elements than old shape" loc - certifying dim_ok $ forM arrs $ \arr' -> do + dim_ok <- letSubExp "dim_ok" =<< + eCmpOp (I.CmpEq I.int32) + (eBinOp (I.Mul Int32 I.OverflowUndef) (eSubExp n') (eSubExp m')) + (eSubExp old_dim) + dim_ok_cert <- assert "dim_ok_cert" dim_ok + "new shape has different number of elements than old shape" loc + certifying dim_ok_cert $ forM arrs $ \arr' -> do arr_t <- lookupType arr' letSubExp desc $ I.BasicOp $ I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ I.arrayShape arr_t) arr' @@ -1682,9 +1687,8 @@ -- size. cmp <- letSubExp "write_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int32) si_w sv_w - c <- assertingOne $ - letExp "write_cert" $ I.BasicOp $ - I.Assert cmp "length of index and value array does not match" (loc, mempty) + c <- assert "write_cert" cmp + "length of index and value array does not match" loc certifying c $ letExp (baseString sv ++ "_write_sv") $ I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion si_w] 1 sv_shape) sv @@ -1704,7 +1708,7 @@ let outs = replicate (length valueNames) indexName ++ valueNames results <- forM outs $ \name -> letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name - ensureResultShape asserting "scatter value has wrong size" loc + ensureResultShape "scatter value has wrong size" loc bodyTypes $ resultBody results let lam = I.Lambda { I.lambdaParams = bodyParams @@ -1729,7 +1733,7 @@ constOrShape = const $ I.Prim int32 paramts = closure_ts ++ map constOrShape shapeargs ++ map I.fromDecl value_paramts - args' <- ensureArgShapes asserting "function arguments of wrong shape" + args' <- ensureArgShapes "function arguments of wrong shape" loc (map I.paramName fun_params) paramts (map I.Var closure ++ shapeargs ++ args) argts' <- mapM subExpType args' diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs --- a/src/Futhark/Internalise/AccurateSizes.hs +++ b/src/Futhark/Internalise/AccurateSizes.hs @@ -14,7 +14,8 @@ import qualified Data.Set as S import Futhark.Construct -import Futhark.IR +import Futhark.Internalise.Monad +import Futhark.IR.SOACS argShapes :: [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> [SubExp] argShapes shapes valts valargts = @@ -25,30 +26,24 @@ Just s | se:_ <- S.toList s -> se _ -> intConst Int32 0 -ensureResultShape :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> [Type] -> Body (Lore m) - -> m (Body (Lore m)) -ensureResultShape asserting msg loc = - ensureResultExtShape asserting msg loc . staticShapes +ensureResultShape :: ErrorMsg SubExp -> SrcLoc -> [Type] -> Body + -> InternaliseM Body +ensureResultShape msg loc = + ensureResultExtShape msg loc . staticShapes -ensureResultExtShape :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body (Lore m) - -> m (Body (Lore m)) -ensureResultExtShape asserting msg loc rettype body = +ensureResultExtShape :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body + -> InternaliseM Body +ensureResultExtShape msg loc rettype body = insertStmsM $ do reses <- bodyBind =<< - ensureResultExtShapeNoCtx asserting msg loc rettype body + ensureResultExtShapeNoCtx msg loc rettype body ts <- mapM subExpType reses let ctx = extractShapeContext rettype $ map arrayDims ts mkBodyM mempty $ ctx ++ reses -ensureResultExtShapeNoCtx :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body (Lore m) - -> m (Body (Lore m)) -ensureResultExtShapeNoCtx asserting msg loc rettype body = +ensureResultExtShapeNoCtx :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body + -> InternaliseM Body +ensureResultExtShapeNoCtx msg loc rettype body = insertStmsM $ do es <- bodyBind body es_ts <- mapM subExpType es @@ -56,56 +51,47 @@ rettype' = foldr (uncurry fixExt) rettype $ M.toList ext_mapping assertProperShape t se = let name = "result_proper_shape" - in ensureExtShape asserting msg loc t name se + in ensureExtShape msg loc t name se resultBodyM =<< zipWithM assertProperShape rettype' es -ensureExtShape :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> SubExp - -> m SubExp -ensureExtShape asserting msg loc t name orig +ensureExtShape :: ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> SubExp + -> InternaliseM SubExp +ensureExtShape msg loc t name orig | Array{} <- t, Var v <- orig = - Var <$> ensureShapeVar asserting msg loc t name v + Var <$> ensureShapeVar msg loc t name v | otherwise = return orig -ensureShape :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> Type -> String -> SubExp - -> m SubExp -ensureShape asserting msg loc = ensureExtShape asserting msg loc . staticShapes1 +ensureShape :: ErrorMsg SubExp -> SrcLoc -> Type -> String -> SubExp + -> InternaliseM SubExp +ensureShape msg loc = ensureExtShape msg loc . staticShapes1 -- | Reshape the arguments to a function so that they fit the expected -- shape declarations. Not used to change rank of arguments. Assumes -- everything is otherwise type-correct. -ensureArgShapes :: (MonadBinder m, Typed (TypeBase Shape u)) => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> [VName] -> [TypeBase Shape u] -> [SubExp] - -> m [SubExp] -ensureArgShapes asserting msg loc shapes paramts args = +ensureArgShapes :: (Typed (TypeBase Shape u)) => + ErrorMsg SubExp -> SrcLoc -> [VName] -> [TypeBase Shape u] -> [SubExp] + -> InternaliseM [SubExp] +ensureArgShapes msg loc shapes paramts args = zipWithM ensureArgShape (expectedTypes shapes paramts args) args where ensureArgShape _ (Constant v) = return $ Constant v ensureArgShape t (Var v) | arrayRank t < 1 = return $ Var v | otherwise = - ensureShape asserting msg loc t (baseString v) $ Var v + ensureShape msg loc t (baseString v) $ Var v -ensureShapeVar :: MonadBinder m => - (m Certificates -> m Certificates) - -> ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> VName - -> m VName -ensureShapeVar asserting msg loc t name v +ensureShapeVar :: ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> VName + -> InternaliseM VName +ensureShapeVar msg loc t name v | Array{} <- t = do newdims <- arrayDims . removeExistentials t <$> lookupType v olddims <- arrayDims <$> lookupType v if newdims == olddims then return v else do - certs <- asserting $ do - matches <- zipWithM checkDim newdims olddims - all_match <- letSubExp "match" =<< eAll matches - Certificates . pure <$> letExp "empty_or_match_cert" - (BasicOp $ Assert all_match msg (loc, [])) - certifying certs $ letExp name $ shapeCoerce newdims v + matches <- zipWithM checkDim newdims olddims + all_match <- letSubExp "match" =<< eAll matches + cs <- assert "empty_or_match_cert" all_match msg loc + certifying cs $ letExp name $ shapeCoerce newdims v | otherwise = return v where checkDim desired has = letSubExp "dim_match" $ BasicOp $ CmpOp (CmpEq int32) desired has 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 @@ -162,7 +162,7 @@ forM (zip exts ses) $ \(et, se) -> do se_t <- I.subExpType se et' <- unExistentialise mempty et se_t - ensureExtShape asserting (I.ErrorMsg [I.ErrorString "value cannot match pattern"]) + ensureExtShape (I.ErrorMsg [I.ErrorString "value cannot match pattern"]) loc et' "correct_shape" se unExistentialise :: S.Set VName -> I.ExtType -> I.Type -> InternaliseM I.ExtType diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -402,10 +402,6 @@ staticField (svFromType t) sv2 fs' staticField _ sv2 _ = sv2 -defuncExp (Unsafe e1 loc) = do - (e1', sv) <- defuncExp e1 - return (Unsafe e1' loc, sv) - defuncExp (Assert e1 e2 desc loc) = do (e1', _) <- defuncExp e1 (e2', sv) <- defuncExp e2 @@ -735,6 +731,7 @@ , valBindParams = pats , valBindBody = body , valBindDoc = Nothing + , valBindAttrs = mempty , valBindLocation = mempty } @@ -852,9 +849,15 @@ (n, updatePattern p sv)) ps' svs') loc updatePattern (PatternParens pat loc) sv = PatternParens (updatePattern pat sv) loc -updatePattern pat@(Id vn (Info tp) loc) sv - | orderZero tp = pat - | otherwise = Id vn (Info $ typeFromSV sv `setUniqueness` Nonunique) loc +updatePattern (Id vn (Info tp) loc) sv = + Id vn (Info $ comb tp (typeFromSV sv `setUniqueness` Nonunique)) loc + -- Preserve any original zeroth-order types. + where comb (Scalar Arrow{}) t2 = t2 + comb (Scalar (Record m1)) (Scalar (Record m2)) = + Scalar $ Record $ M.intersectionWith comb m1 m2 + comb (Scalar (Sum m1)) (Scalar (Sum m2)) = + Scalar $ Sum $ M.intersectionWith (zipWith comb) m1 m2 + comb t1 _ = t1 -- t1 must be array or prim. updatePattern pat@(Wildcard (Info tp) loc) sv | orderZero tp = pat | otherwise = Wildcard (Info $ typeFromSV sv) loc @@ -967,7 +970,6 @@ Update e1 idxs e2 _ -> freeVars e1 <> foldMap freeDimIndex idxs <> freeVars e2 RecordUpdate e1 _ e2 _ _ -> freeVars e1 <> freeVars e2 - Unsafe e _ -> freeVars e Assert e1 e2 _ _ -> freeVars e1 <> freeVars e2 Constr _ es _ _ -> foldMap freeVars es Attr _ e _ -> freeVars e @@ -991,14 +993,14 @@ defuncValBind :: ValBind -> DefM (ValBind, Env, Bool) -- Eta-expand entry points with a functional return type. -defuncValBind (ValBind entry name _ (Info (rettype, retext)) tparams params body _ loc) +defuncValBind (ValBind entry name _ (Info (rettype, retext)) tparams params body _ attrs loc) | Scalar Arrow{} <- rettype = do (body_pats, body', rettype') <- etaExpand (fromStruct rettype) body defuncValBind $ ValBind entry name Nothing (Info (rettype', retext)) - tparams (params <> body_pats) body' Nothing loc + tparams (params <> body_pats) body' Nothing attrs loc -defuncValBind valbind@(ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ _) = do +defuncValBind valbind@(ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ _ _) = do (tparams', params', body', sv) <- defuncLet tparams params body rettype let rettype' = combineTypeShapes rettype $ anySizes $ toStruct $ typeOf body' return ( valbind { valBindRetDecl = retdecl diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -239,14 +239,14 @@ transformExp = transformNames transformValBind :: ValBind -> TransformM () -transformValBind (ValBind entry name tdecl (Info (t, retext)) tparams params e doc loc) = do +transformValBind (ValBind entry name tdecl (Info (t, retext)) tparams params e doc attrs loc) = do name' <- transformName name tdecl' <- traverse transformTypeExp tdecl t' <- transformStructType t e' <- transformExp e tparams' <- traverse transformNames tparams params' <- traverse transformNames params - emit $ ValDec $ ValBind entry name' tdecl' (Info (t', retext)) tparams' params' e' doc loc + emit $ ValDec $ ValBind entry name' tdecl' (Info (t', retext)) tparams' params' e' doc attrs loc transformTypeDecl :: TypeDecl -> TransformM TypeDecl transformTypeDecl (TypeDecl dt (Info et)) = diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs --- a/src/Futhark/Internalise/Lambdas.hs +++ b/src/Futhark/Internalise/Lambdas.hs @@ -29,7 +29,7 @@ (params, body, rettype) <- internaliseLambda lam rowtypes (rettype', _) <- instantiateShapes' rettype body' <- localScope (scopeOfLParams params) $ - ensureResultShape asserting + ensureResultShape (ErrorMsg [ErrorString "not all iterations produce same shape"]) (srclocOf lam) rettype' body return $ I.Lambda params body' rettype' @@ -53,7 +53,7 @@ (rettype', _) <- instantiateShapes' rettype body' <- localScope (scopeOfLParams params) $ insertStmsM $ do letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size - ensureResultShape asserting + ensureResultShape (ErrorMsg [ErrorString "not all iterations produce same shape"]) (srclocOf lam) (map outer rettype') body return $ I.Lambda (chunk_param:params) body' (map outer rettype') @@ -71,7 +71,7 @@ -- initial accumulator. We accomplish this with an assertion and -- reshape(). body' <- localScope (scopeOfLParams params) $ - ensureResultShape asserting + ensureResultShape (ErrorMsg [ErrorString "shape of result does not match shape of initial value"]) (srclocOf lam) rettype' body return $ I.Lambda params body' rettype' diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} module Futhark.Internalise.Monad ( InternaliseM @@ -23,8 +27,7 @@ , localConstsScope - , asserting - , assertingOne + , assert -- * Type Handling , InternaliseTypeM @@ -187,6 +190,16 @@ localConstsScope m = do scope <- gets stateConstScope localScope scope m + +-- | Construct an 'Assert' statement, but taking attributes into +-- account. Always use this function, and never construct 'Assert' +-- directly in the internaliser! +assert :: String -> SubExp -> ErrorMsg SubExp -> SrcLoc + -> InternaliseM Certificates +assert desc se msg loc = assertingOne $ do + attrs <- asks $ attrsForAssert . envAttrs + attributing attrs $ letExp desc $ + BasicOp $ Assert se msg (loc, mempty) -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list. diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -26,6 +26,7 @@ module Futhark.Internalise.Monomorphise ( transformProg ) where +import Control.Monad.Identity import Control.Monad.RWS hiding (Sum) import Control.Monad.State import Control.Monad.Writer hiding (Sum) @@ -56,7 +57,8 @@ -- in local functions. data PolyBinding = PolyBinding RecordReplacements (VName, [TypeParam], [Pattern], - Maybe (TypeExp VName), StructType, [VName], Exp, SrcLoc) + Maybe (TypeExp VName), StructType, [VName], Exp, + [AttrInfo], SrcLoc) -- Mapping from record names to the variable names that contain the -- fields. This is used because the monomorphiser also expands all @@ -118,13 +120,16 @@ -- The kind of type relative to which we monomorphise. What is -- important to us is not the specific dimensions, but merely whether --- they are known or anonymous (the latter False). +-- they are known or anonymous/local (the latter False). type MonoType = TypeBase Bool () monoType :: TypeBase (DimDecl VName) als -> MonoType -monoType = bimap onDim (const ()) - where onDim AnyDim = False - onDim _ = True +monoType = runIdentity . traverseDims onDim . toStruct + where onDim bound _ (NamedDim d) + -- A locally bound size. + | qualLeaf d `S.member` bound = pure False + onDim _ _ AnyDim = pure False + onDim _ _ _ = pure True -- Mapping from function name and instance list to a new function name in case -- the function has already been instantiated with those concrete types. @@ -260,7 +265,7 @@ -- filter those that are monomorphic versions of the current let-bound -- function and insert them at this point, and propagate the rest. rr <- asks envRecordReplacements - let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, [], body, loc) + let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, [], body, mempty, loc) pass $ do (e', bs) <- listen $ extendEnv fname funbind $ transformExp e -- Do not remember this one for next time we monomorphise this @@ -388,9 +393,6 @@ RecordUpdate <$> transformExp e1 <*> pure fs <*> transformExp e2 <*> pure t <*> pure loc -transformExp (Unsafe e1 loc) = - Unsafe <$> transformExp e1 <*> pure loc - transformExp (Assert e1 e2 desc loc) = Assert <$> transformExp e1 <*> transformExp e2 <*> pure desc <*> pure loc @@ -466,7 +468,7 @@ -- monomorphic functions with the given expression at the bottom. unfoldLetFuns :: [ValBind] -> Exp -> Exp unfoldLetFuns [] e = e -unfoldLetFuns (ValBind _ fname _ (Info (rettype, _)) dim_params params body _ loc : rest) e = +unfoldLetFuns (ValBind _ fname _ (Info (rettype, _)) dim_params params body _ _ loc : rest) e = LetFun fname (dim_params, params, Nothing, Info rettype, body) e' (Info e_t) loc where e' = unfoldLetFuns rest e e_t = typeOf e' @@ -565,7 +567,7 @@ -- of the generated monomorphic function and its 'ValBind' representation. monomorphiseBinding :: Bool -> PolyBinding -> MonoType -> MonoM (VName, InferSizeArgs, ValBind) -monomorphiseBinding entry (PolyBinding rr (name, tparams, params, retdecl, rettype, retext, body, loc)) t = +monomorphiseBinding entry (PolyBinding rr (name, tparams, params, retdecl, rettype, retext, body, attrs, loc)) t = replaceRecordReplacements rr $ do let bind_t = foldFunType (map patternStructType params) rettype (substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams t @@ -618,6 +620,7 @@ , valBindParams = params'' , valBindBody = body'' , valBindDoc = Nothing + , valBindAttrs = attrs , valBindLocation = loc } @@ -674,12 +677,12 @@ PatternConstr n (Info tp) ps loc -> PatternConstr n (Info $ f tp) ps loc toPolyBinding :: ValBind -> PolyBinding -toPolyBinding (ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ loc) = - PolyBinding mempty (name, tparams, params, retdecl, rettype, retext, body, loc) +toPolyBinding (ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ attrs loc) = + PolyBinding mempty (name, tparams, params, retdecl, rettype, retext, body, attrs, loc) -- Remove all type variables and type abbreviations from a value binding. removeTypeVariables :: Bool -> ValBind -> MonoM ValBind -removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _) = do +removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _ _) = do subs <- asks $ M.map TypeSub . envTypeBindings let mapper = ASTMapper { mapOnExp = astMap mapper diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs --- a/src/Futhark/Optimise/Fusion.hs +++ b/src/Futhark/Optimise/Fusion.hs @@ -30,6 +30,7 @@ import Futhark.Transform.Rename import Futhark.Transform.Substitute import Futhark.Pass +import Futhark.Util (maxinum) data VarEntry = IsArray VName (NameInfo SOACS) Names SOAC.Input | IsNotArray (NameInfo SOACS) @@ -470,7 +471,7 @@ ker <- lookupKernel ker_nm case mapMaybe (\out_nm -> L.findIndex (elem out_nm) bnd_nms) (outNames ker) of [] -> return Nothing - is -> return $ Just (ker,ker_nm,maximum is) + is -> return $ Just (ker,ker_nm,maxinum is) scope <- askScope let kernminds' = L.sortBy (\(_,_,i1) (_,_,i2)->compare i1 i2) $ catMaybes kernminds @@ -865,8 +866,7 @@ simplifyAndFuseInLambda :: Lambda -> FusionGM Lambda simplifyAndFuseInLambda lam = do - let args = replicate (length $ lambdaParams lam) Nothing - lam' <- simplifyLambda lam args + lam' <- simplifyLambda lam (_, nfres) <- fusionGatherLam (mempty, mkFreshFusionRes) lam' let nfres' = cleanFusionResult nfres bindRes nfres' $ fuseInLambda lam' diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs --- a/src/Futhark/Optimise/InPlaceLowering.hs +++ b/src/Futhark/Optimise/InPlaceLowering.hs @@ -260,7 +260,7 @@ -> ForwardingM lore a bindingScope scope = local $ \(TopDown n vtable d x y) -> let entries = M.map entry scope - infoAliases (LetName (aliases, _)) = unNames aliases + infoAliases (LetName (aliases, _)) = unAliases aliases infoAliases _ = mempty entry info = Entry n (infoAliases info) d False info in TopDown (n+1) (entries<>vtable) d x y @@ -273,7 +273,7 @@ entry patElem = let (aliases, _) = patElemDec patElem in (patElemName patElem, - Entry n (unNames aliases) d True $ LetName $ patElemDec patElem) + Entry n (unAliases aliases) d True $ LetName $ patElemDec patElem) in TopDown (n+1) (M.union entries vtable) d x y bindingNumber :: VName -> ForwardingM lore Int diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -97,7 +97,8 @@ (vtable', consts', not_to_inline_in <> to_inline_in') keep fd = - isJust (funDefEntryPoint fd) || funDefName fd `S.member` noninlined + isJust (funDefEntryPoint fd) || + funDefName fd `S.member` noninlined -- | @inlineInFunDef constf fdmap caller@ inlines in @calleer@ the -- functions in @fdmap@ that are called as @constf@. At this point the @@ -107,8 +108,8 @@ inlineInFunDef :: MonadFreshNames m => M.Map Name (FunDef SOACS) -> FunDef SOACS -> m (FunDef SOACS) -inlineInFunDef fdmap (FunDef entry name rtp args body) = - FunDef entry name rtp args <$> inlineInBody fdmap body +inlineInFunDef fdmap (FunDef entry attrs name rtp args body) = + FunDef entry attrs name rtp args <$> inlineInBody fdmap body inlineFunction :: MonadFreshNames m => Pattern @@ -159,9 +160,9 @@ inlineInBody fdmap = onBody where inline (Let pat aux (Apply fname args _ what) : rest) | Just fd <- M.lookup fname fdmap, - not noinline = + not $ "noinline" `inAttrs` funDefAttrs fd, + not $ "noinline" `inAttrs` stmAuxAttrs aux = (<>) <$> inlineFunction pat aux args what fd <*> inline rest - where noinline = "noinline" `inAttrs` stmAuxAttrs aux inline (stm : rest) = (:) <$> onStm stm <*> inline rest @@ -197,23 +198,25 @@ Apply fname args t (min caller_safety safety, loc,locs++more_locs) where aux' = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } onStm (Let pat aux (BasicOp (Assert cond desc (loc,locs)))) = - Let pat aux $ + Let pat (withAttrs (attrsForAssert attrs) aux) $ case caller_safety of Safe -> BasicOp $ Assert cond desc (loc,locs++more_locs) Unsafe -> BasicOp $ SubExp $ Constant Checked onStm (Let pat aux (Op soac)) = - Let pat (withAttrs aux) $ Op $ runIdentity $ mapSOACM + Let pat (withAttrs attrs' aux) $ Op $ runIdentity $ mapSOACM identitySOACMapper { mapOnSOACLambda = return . onLambda } soac - where onLambda lam = - lam { lambdaBody = onBody mempty $ lambdaBody lam } + where attrs' = attrs `withoutAttrs` for_assert + for_assert = attrsForAssert attrs + onLambda lam = + lam { lambdaBody = onBody for_assert $ lambdaBody lam } onStm (Let pat aux e) = Let pat aux $ onExp e onExp = mapExp identityMapper { mapOnBody = const $ return . onBody attrs } - withAttrs aux = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } + withAttrs attrs' aux = aux { stmAuxAttrs = attrs' <> stmAuxAttrs aux } onBody attrs' body = body { bodyStms = addLocations attrs' caller_safety more_locs $ diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -104,14 +104,14 @@ Engine.SimpleOps lore -> RuleBook (Engine.Wise lore) -> Engine.HoistBlockers lore - -> Lambda lore -> [Maybe VName] + -> Lambda lore -> m (Lambda lore) -simplifyLambda simpl rules blockers orig_lam args = do +simplifyLambda simpl rules blockers orig_lam = do vtable <- ST.fromScope . addScopeWisdom <$> askScope - simplifySomething f removeLambdaWisdom simpl rules blockers vtable orig_lam - where f lam' = Engine.simplifyLambdaNoHoisting lam' args + simplifySomething Engine.simplifyLambdaNoHoisting + removeLambdaWisdom simpl rules blockers vtable orig_lam --- | Simplify a list of 'Stm's. +-- | Simplify a sequence of 'Stm's. simplifyStms :: (MonadFreshNames m, Engine.SimplifiableLore lore) => Engine.SimpleOps lore -> RuleBook (Engine.Wise lore) 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 @@ -85,18 +85,16 @@ -- ^ Blocker for hoisting out of sequential loops. , blockHoistBranch :: BlockPred (Wise lore) -- ^ Blocker for hoisting out of branches. - , getArraySizes :: Stm (Wise lore) -> Names - -- ^ gets the sizes of arrays from a binding. , isAllocation :: Stm (Wise lore) -> Bool } noExtraHoistBlockers :: HoistBlockers lore noExtraHoistBlockers = - HoistBlockers neverBlocks neverBlocks neverBlocks (const mempty) (const False) + HoistBlockers neverBlocks neverBlocks neverBlocks (const False) neverHoist :: HoistBlockers lore neverHoist = - HoistBlockers alwaysBlocks alwaysBlocks alwaysBlocks (const mempty) (const False) + HoistBlockers alwaysBlocks alwaysBlocks alwaysBlocks (const False) data Env lore = Env { envRules :: RuleBook (Wise lore) , envHoistBlockers :: HoistBlockers lore @@ -123,6 +121,7 @@ -- ^ Make a hoisted Op safe. The SubExp is a boolean -- that is true when the value of the statement will -- actually be used. + , opUsageS :: Op (Wise lore) -> UT.UsageTable , simplifyOpS :: SimplifyOp lore (Op lore) } @@ -130,7 +129,8 @@ bindableSimpleOps :: (SimplifiableLore lore, Bindable lore) => SimplifyOp lore (Op lore) -> SimpleOps lore -bindableSimpleOps = SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' +bindableSimpleOps = + SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' (const mempty) where mkExpDecS' _ pat e = return $ mkExpDec pat e mkBodyS' _ bnds res = return $ mkBody bnds res protectHoistedOpS' _ _ _ = Nothing @@ -199,32 +199,22 @@ enterLoop :: SimpleM lore a -> SimpleM lore a enterLoop = localVtable ST.deepen -bindFParams :: SimplifiableLore lore => - [FParam (Wise lore)] -> SimpleM lore a -> SimpleM lore a +bindFParams :: SimplifiableLore lore => [FParam (Wise lore)] -> SimpleM lore a -> SimpleM lore a bindFParams params = localVtable $ ST.insertFParams params -bindLParams :: SimplifiableLore lore => - [LParam (Wise lore)] -> SimpleM lore a -> SimpleM lore a +bindLParams :: SimplifiableLore lore => [LParam (Wise lore)] -> SimpleM lore a -> SimpleM lore a bindLParams params = - localVtable $ \vtable -> - foldr ST.insertLParam vtable params + localVtable $ \vtable -> foldr ST.insertLParam vtable params -bindArrayLParams :: SimplifiableLore lore => - [(LParam (Wise lore),Maybe VName)] -> SimpleM lore a +bindArrayLParams :: SimplifiableLore lore => [LParam (Wise lore)] -> SimpleM lore a -> SimpleM lore a bindArrayLParams params = - localVtable $ \vtable -> - foldr (uncurry ST.insertArrayLParam) vtable params + localVtable $ \vtable -> foldl' (flip ST.insertLParam) vtable params -bindLoopVar :: SimplifiableLore lore => - VName -> IntType -> SubExp -> SimpleM lore a -> SimpleM lore a +bindLoopVar :: SimplifiableLore lore => VName -> IntType -> SubExp -> SimpleM lore a -> SimpleM lore a bindLoopVar var it bound = - localVtable $ clampUpper . clampVar - where clampVar = ST.insertLoopVar var it bound - -- If we enter the loop, then 'bound' is at least one. - clampUpper = case bound of Var v -> ST.isAtLeast v 1 - _ -> id + localVtable $ ST.insertLoopVar var it bound -- | We are willing to hoist potentially unsafe statements out of -- branches, but they most be protected by adding a branch on top of @@ -295,17 +285,41 @@ | Just m <- protect taken pat op = auxing aux m protectIf _ f taken (Let pat aux e) - | f e = do - taken_body <- eBody [pure e] - untaken_body <- eBody $ map (emptyOfType $ patternContextNames pat) - (patternValueTypes pat) - if_ts <- expTypesFromPattern pat - auxing aux $ - letBind pat $ If taken taken_body untaken_body $ - IfDec if_ts IfFallback + | f e = + case makeSafe e of + Just e' -> + auxing aux $ letBind pat e' + Nothing -> do + taken_body <- eBody [pure e] + untaken_body <- eBody $ map (emptyOfType $ patternContextNames pat) + (patternValueTypes pat) + if_ts <- expTypesFromPattern pat + auxing aux $ + letBind pat $ If taken taken_body untaken_body $ + IfDec if_ts IfFallback protectIf _ _ _ stm = addStm stm +makeSafe :: Exp lore -> Maybe (Exp lore) +makeSafe (BasicOp (BinOp (SDiv t _) x y)) = + Just $ BasicOp (BinOp (SDiv t Safe) x y) +makeSafe (BasicOp (BinOp (SDivUp t _) x y)) = + Just $ BasicOp (BinOp (SDivUp t Safe) x y) +makeSafe (BasicOp (BinOp (SQuot t _) x y)) = + Just $ BasicOp (BinOp (SQuot t Safe) x y) +makeSafe (BasicOp (BinOp (UDiv t _) x y)) = + Just $ BasicOp (BinOp (UDiv t Safe) x y) +makeSafe (BasicOp (BinOp (UDivUp t _) x y)) = + Just $ BasicOp (BinOp (UDivUp t Safe) x y) +makeSafe (BasicOp (BinOp (SMod t _) x y)) = + Just $ BasicOp (BinOp (SMod t Safe) x y) +makeSafe (BasicOp (BinOp (SRem t _) x y)) = + Just $ BasicOp (BinOp (SRem t Safe) x y) +makeSafe (BasicOp (BinOp (UMod t _) x y)) = + Just $ BasicOp (BinOp (UMod t Safe) x y) +makeSafe _ = + Nothing + emptyOfType :: MonadBinder m => [VName] -> Type -> m (Exp (Lore m)) emptyOfType _ Mem{} = error "emptyOfType: Cannot hoist non-existential memory." @@ -341,11 +355,17 @@ let (blocked, hoisted) = partitionEithers $ blockUnhoistedDeps stms' return (blocked, hoisted) - simplifyStmsBottomUp' vtable' uses' stms = - foldM hoistable (uses',[]) $ reverse $ zip (stmsToList stms) vtables + simplifyStmsBottomUp' vtable' uses' stms = do + opUsage <- asks $ opUsageS . fst + let usageInStm stm = + UT.usageInStm stm <> + case stmExp stm of + Op op -> opUsage op + _ -> mempty + foldM (hoistable usageInStm) (uses',[]) $ reverse $ zip (stmsToList stms) vtables where vtables = scanl (flip ST.insertStm) vtable' $ stmsToList stms - hoistable (uses',stms) (stm, vtable') + hoistable usageInStm (uses',stms) (stm, vtable') | not $ any (`UT.isUsedDirectly` uses') $ provides stm = -- Dead statement. return (uses', stms) | otherwise = do @@ -354,11 +374,12 @@ case res of Nothing -- Nothing to optimise - see if hoistable. | block vtable' uses' stm -> - return (expandUsage vtable' uses' stm - `UT.without` provides stm, - Left stm : stms) + return (expandUsage usageInStm vtable' uses' stm + `UT.without` provides stm, + Left stm : stms) | otherwise -> - return (expandUsage vtable' uses' stm, Right stm : stms) + return (expandUsage usageInStm vtable' uses' stm, + Right stm : stms) Just optimstms -> do changed (uses'',stms') <- simplifyStmsBottomUp' vtable' uses' optimstms @@ -380,12 +401,15 @@ provides = patternNames . stmPattern expandUsage :: (ASTLore lore, Aliased lore) => - ST.SymbolTable lore -> UT.UsageTable -> Stm lore -> UT.UsageTable -expandUsage vtable utable bnd = - UT.expand (`ST.lookupAliases` vtable) (UT.usageInStm bnd <> usageThroughAliases) <> + (Stm lore -> UT.UsageTable) -> ST.SymbolTable lore -> UT.UsageTable + -> Stm lore -> UT.UsageTable +expandUsage usageInStm vtable utable stm@(Let pat _ e) = + UT.expand (`ST.lookupAliases` vtable) (usageInStm stm <> usageThroughAliases) <> + (if any (`UT.isSize` utable) (patternNames pat) + then UT.sizeUsages (freeIn e) + else mempty) <> utable - where pat = stmPattern bnd - usageThroughAliases = + where usageThroughAliases = mconcat $ mapMaybe usageThroughBindeeAliases $ zip (patternNames pat) (patternAliases pat) usageThroughBindeeAliases (name, aliases) = do @@ -459,6 +483,7 @@ cheapExp (BasicOp CmpOp{}) = True cheapExp (BasicOp ConvOp{}) = True cheapExp (BasicOp Copy{}) = False +cheapExp (BasicOp Manifest{}) = False cheapExp DoLoop{} = False cheapExp (If _ tbranch fbranch _) = all cheapStm (bodyStms tbranch) && all cheapStm (bodyStms fbranch) @@ -482,7 +507,6 @@ Stms (Wise lore)) hoistCommon cond ifsort ((res1, usages1), stms1) ((res2, usages2), stms2) = do is_alloc_fun <- asksEngineEnv $ isAllocation . envHoistBlockers - getArrSz_fun <- asksEngineEnv $ getArraySizes . envHoistBlockers branch_blocker <- asksEngineEnv $ blockHoistBranch . envHoistBlockers vtable <- askVtable let -- We are unwilling to hoist things that are unsafe or costly, @@ -490,10 +514,9 @@ -- because in that case they will also be hoisted past that -- loop. -- - -- "isNotHoistableBnd hoistbl_nms" ensures that only the - -- (transitive closure) of the bindings used for allocations, - -- shape computations, and expensive loop-invariant operations - -- are if-hoistable. + -- We also try very hard to hoist allocations or anything that + -- contributes to memory or array size, because that will allow + -- allocations to be hoisted. cond_loop_invariant = all (`nameIn` ST.availableAtClosestLoop vtable) $ namesToList $ freeIn cond @@ -504,18 +527,20 @@ ifsort /= IfFallback && loopInvariantStm vtable stm) - hoistbl_nms = filterBnds desirableToHoist getArrSz_fun $ - stmsToList $ stms1<>stms2 - -- No matter what, we always want to hoist constants as much as -- possible. - isNotHoistableBnd _ _ _ (Let _ _ (BasicOp ArrayLit{})) = False - isNotHoistableBnd _ _ _ (Let _ _ (BasicOp SubExp{})) = False - isNotHoistableBnd nms _ _ stm = not (hasPatName nms stm) + isNotHoistableBnd _ _ (Let _ _ (BasicOp ArrayLit{})) = False + isNotHoistableBnd _ _ (Let _ _ (BasicOp SubExp{})) = False + isNotHoistableBnd _ usages (Let pat _ _) + | any (`UT.isSize` usages) $ patternNames pat = + False + isNotHoistableBnd _ _ _ = + -- Hoist aggressively out of versioning branches. + ifsort /= IfEquiv block = branch_blocker `orIf` ((isNotSafe `orIf` isNotCheap) `andAlso` stmIs (not . desirableToHoist)) - `orIf` isInPlaceBound `orIf` isNotHoistableBnd hoistbl_nms + `orIf` isInPlaceBound `orIf` isNotHoistableBnd rules <- asksEngineEnv envRules (body1_bnds', safe1) <- protectIfHoisted cond True $ @@ -526,21 +551,6 @@ body1' <- constructBody body1_bnds' res1 body2' <- constructBody body2_bnds' res2 return (body1', body2', hoistable) - where filterBnds interesting getArrSz_fn all_bnds = - let sz_nms = mconcat $ map getArrSz_fn all_bnds - sz_needs = transClosSizes all_bnds sz_nms [] - alloc_bnds = filter interesting all_bnds - sel_nms = namesFromList $ - concatMap (patternNames . stmPattern) - (sz_needs ++ alloc_bnds) - in sel_nms - transClosSizes all_bnds scal_nms hoist_bnds = - let new_bnds = filter (hasPatName scal_nms) all_bnds - new_nms = mconcat $ map (freeIn . stmExp) new_bnds - in if null new_bnds - then hoist_bnds - else transClosSizes all_bnds new_nms (new_bnds ++ hoist_bnds) - hasPatName nms bnd = any (`nameIn` nms) $ patternNames $ stmPattern bnd -- | Simplify a single body. The @[Diet]@ only covers the value -- elements, because the context cannot be consumed. @@ -640,8 +650,8 @@ -- (or else, If expressions should indicate explicitly the diet of -- their return types). let ds = map (const Consume) ts - tbranch' <- localVtable (ST.updateBounds True cond) $ simplifyBody ds tbranch - fbranch' <- localVtable (ST.updateBounds False cond) $ simplifyBody ds fbranch + tbranch' <- simplifyBody ds tbranch + fbranch' <- simplifyBody ds fbranch (tbranch'',fbranch'', hoisted) <- hoistCommon cond' ifsort tbranch' fbranch' return (If cond' tbranch'' fbranch'' $ IfDec ts' ifsort, hoisted) @@ -666,7 +676,7 @@ namesFromList (loopvar : map paramName loop_params') <> fparamnames, bindLoopVar loopvar it boundexp' . protectLoopHoisted ctx' val' form' . - bindArrayLParams (zip loop_params' (map Just loop_arrs'))) + bindArrayLParams loop_params') WhileLoop cond -> do cond' <- simplify cond return (WhileLoop cond', @@ -820,32 +830,26 @@ simplifyLambda :: SimplifiableLore lore => Lambda lore - -> [Maybe VName] -> SimpleM lore (Lambda (Wise lore), Stms (Wise lore)) -simplifyLambda lam arrs = do +simplifyLambda lam = do par_blocker <- asksEngineEnv $ blockHoistPar . envHoistBlockers - simplifyLambdaMaybeHoist par_blocker lam arrs + simplifyLambdaMaybeHoist par_blocker lam simplifyLambdaNoHoisting :: SimplifiableLore lore => Lambda lore - -> [Maybe VName] -> SimpleM lore (Lambda (Wise lore)) -simplifyLambdaNoHoisting lam arr = - fst <$> simplifyLambdaMaybeHoist (isFalse False) lam arr +simplifyLambdaNoHoisting lam = + fst <$> simplifyLambdaMaybeHoist (isFalse False) lam simplifyLambdaMaybeHoist :: SimplifiableLore lore => BlockPred (Wise lore) -> Lambda lore - -> [Maybe VName] -> SimpleM lore (Lambda (Wise lore), Stms (Wise lore)) -simplifyLambdaMaybeHoist blocked lam@(Lambda params body rettype) arrs = do +simplifyLambdaMaybeHoist blocked lam@(Lambda params body rettype) = do params' <- mapM (traverse simplify) params - let (nonarrayparams, arrayparams) = - splitAt (length params' - length arrs) params' - paramnames = namesFromList $ boundByLambda lam + let paramnames = namesFromList $ boundByLambda lam ((lamstms, lamres), hoisted) <- enterLoop $ - bindLParams nonarrayparams $ - bindArrayLParams (zip arrayparams arrs) $ + bindLParams params' $ blockIf (blocked `orIf` hasFree paramnames `orIf` isConsumed) $ simplifyBody (map (const Observe) rettype) body body' <- constructBody lamstms lamres @@ -876,9 +880,9 @@ simplifyFun :: SimplifiableLore lore => FunDef lore -> SimpleM lore (FunDef (Wise lore)) -simplifyFun (FunDef entry fname rettype params body) = do +simplifyFun (FunDef entry attrs fname rettype params body) = do rettype' <- simplify rettype params' <- mapM (traverse simplify) params let ds = map (diet . declExtTypeOf) rettype' body' <- bindFParams params $ insertAllStms $ simplifyBody ds body - return $ FunDef entry fname rettype' params' body' + return $ FunDef entry attrs fname rettype' params' body' diff --git a/src/Futhark/Optimise/Simplify/Lore.hs b/src/Futhark/Optimise/Simplify/Lore.hs --- a/src/Futhark/Optimise/Simplify/Lore.hs +++ b/src/Futhark/Optimise/Simplify/Lore.hs @@ -31,12 +31,10 @@ import qualified Data.Map.Strict as M import Futhark.IR -import Futhark.IR.Prop.Ranges import Futhark.IR.Prop.Aliases import Futhark.IR.Aliases - (unNames, Names' (..), VarAliases, ConsumedInExp) + (unAliases, AliasDec (..), VarAliases, ConsumedInExp) import qualified Futhark.IR.Aliases as Aliases -import qualified Futhark.IR.Ranges as Ranges import Futhark.Binder import Futhark.Transform.Rename import Futhark.Transform.Substitute @@ -45,24 +43,22 @@ data Wise lore -- | The wisdom of the let-bound variable. -data VarWisdom = VarWisdom { varWisdomAliases :: VarAliases - , varWisdomRange :: Range - } +newtype VarWisdom = VarWisdom { varWisdomAliases :: VarAliases } deriving (Eq, Ord, Show) instance Rename VarWisdom where rename = substituteRename instance Substitute VarWisdom where - substituteNames substs (VarWisdom als range) = - VarWisdom (substituteNames substs als) (substituteNames substs range) + substituteNames substs (VarWisdom als) = + VarWisdom (substituteNames substs als) instance FreeIn VarWisdom where - freeIn' (VarWisdom als range) = freeIn' als <> freeIn' range + freeIn' (VarWisdom als) = freeIn' als -- | Wisdom about an expression. data ExpWisdom = ExpWisdom { _expWisdomConsumed :: ConsumedInExp - , expWisdomFree :: Names' + , expWisdomFree :: AliasDec } deriving (Eq, Ord, Show) @@ -70,7 +66,7 @@ freeIn' = mempty instance FreeDec ExpWisdom where - precomputed = const . fvNames . unNames . expWisdomFree + precomputed = const . fvNames . unAliases . expWisdomFree instance Substitute ExpWisdom where substituteNames substs (ExpWisdom cons free) = @@ -84,8 +80,7 @@ -- | Wisdom about a body. data BodyWisdom = BodyWisdom { bodyWisdomAliases :: [VarAliases] , bodyWisdomConsumed :: ConsumedInExp - , bodyWisdomRanges :: [Range] - , bodyWisdomFree :: Names' + , bodyWisdomFree :: AliasDec } deriving (Eq, Ord, Show) @@ -93,19 +88,18 @@ rename = substituteRename instance Substitute BodyWisdom where - substituteNames substs (BodyWisdom als cons rs free) = + substituteNames substs (BodyWisdom als cons free) = BodyWisdom (substituteNames substs als) (substituteNames substs cons) - (substituteNames substs rs) (substituteNames substs free) instance FreeIn BodyWisdom where - freeIn' (BodyWisdom als cons rs free) = - freeIn' als <> freeIn' cons <> freeIn' rs <> freeIn' free + freeIn' (BodyWisdom als cons free) = + freeIn' als <> freeIn' cons <> freeIn' free instance FreeDec BodyWisdom where - precomputed = const . fvNames . unNames . bodyWisdomFree + precomputed = const . fvNames . unAliases . bodyWisdomFree instance (Decorations lore, CanBeWise (Op lore)) => Decorations (Wise lore) where @@ -136,17 +130,11 @@ ppExpLore (_, dec) = ppExpLore dec . removeExpWisdom instance AliasesOf (VarWisdom, dec) where - aliasesOf = unNames . varWisdomAliases . fst - -instance RangeOf (VarWisdom, dec) where - rangeOf = varWisdomRange . fst - -instance RangesOf (BodyWisdom, dec) where - rangesOf = bodyWisdomRanges . fst + aliasesOf = unAliases . varWisdomAliases . fst instance (ASTLore lore, CanBeWise (Op lore)) => Aliased (Wise lore) where - bodyAliases = map unNames . bodyWisdomAliases . fst . bodyDec - consumedInBody = unNames . bodyWisdomConsumed . fst . bodyDec + bodyAliases = map unAliases . bodyWisdomAliases . fst . bodyDec + consumedInBody = unAliases . bodyWisdomConsumed . fst . bodyDec removeWisdom :: CanBeWise (Op lore) => Rephraser Identity (Wise lore) lore removeWisdom = Rephraser { rephraseExpLore = return . snd @@ -168,7 +156,7 @@ addScopeWisdom :: Scope lore -> Scope (Wise lore) addScopeWisdom = M.map alias - where alias (LetName dec) = LetName (VarWisdom mempty unknownRange, dec) + where alias (LetName dec) = LetName (VarWisdom mempty, dec) alias (FParamName dec) = FParamName dec alias (LParamName dec) = LParamName dec alias (IndexName it) = IndexName it @@ -196,22 +184,17 @@ -> Exp (Wise lore) -> Pattern (Wise lore) addWisdomToPattern pat e = - Pattern - (map (`addRanges` unknownRange) ctxals) - (zipWith addRanges valals ranges) - where (ctxals, valals) = Aliases.mkPatternAliases pat e - addRanges patElem range = - let (als, innerlore) = patElemDec patElem - in patElem `setPatElemLore` (VarWisdom als range, innerlore) - ranges = expRanges e + Pattern (map f ctx) (map f val) + where (ctx, val) = Aliases.mkPatternAliases pat e + f pe = let (als, dec) = patElemDec pe + in pe `setPatElemLore` (VarWisdom als, dec) mkWiseBody :: (ASTLore lore, CanBeWise (Op lore)) => BodyDec lore -> Stms (Wise lore) -> Result -> Body (Wise lore) mkWiseBody innerlore bnds res = - Body (BodyWisdom aliases consumed ranges (Names' $ freeIn $ freeInStmsAndRes bnds res), + Body (BodyWisdom aliases consumed (AliasDec $ freeIn $ freeInStmsAndRes bnds res), innerlore) bnds res where (aliases, consumed) = Aliases.mkBodyAliases bnds res - ranges = Ranges.mkBodyRanges bnds res mkWiseLetStm :: (ASTLore lore, CanBeWise (Op lore)) => Pattern lore @@ -226,8 +209,8 @@ -> ExpDec (Wise lore) mkWiseExpDec pat explore e = (ExpWisdom - (Names' $ consumedInExp e) - (Names' $ freeIn pat <> freeIn explore <> freeIn e), + (AliasDec $ consumedInExp e) + (AliasDec $ freeIn pat <> freeIn explore <> freeIn e), explore) instance (Bindable lore, @@ -249,7 +232,6 @@ in mkWiseBody bodylore bnds res class (AliasedOp (OpWithWisdom op), - RangedOp (OpWithWisdom op), IsOp (OpWithWisdom op)) => CanBeWise op where type OpWithWisdom op :: Data.Kind.Type removeOpWisdom :: OpWithWisdom op -> op diff --git a/src/Futhark/Optimise/Simplify/Rule.hs b/src/Futhark/Optimise/Simplify/Rule.hs --- a/src/Futhark/Optimise/Simplify/Rule.hs +++ b/src/Futhark/Optimise/Simplify/Rule.hs @@ -54,25 +54,16 @@ ) where import Control.Monad.State -import qualified Control.Monad.Fail as Fail -import Control.Monad.Except import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT import Futhark.IR import Futhark.Binder -data RuleError = CannotSimplify - | OtherError String - -- | The monad in which simplification rules are evaluated. -newtype RuleM lore a = RuleM (BinderT lore (StateT VNameSource (Except RuleError)) a) +newtype RuleM lore a = RuleM (BinderT lore (StateT VNameSource Maybe) a) deriving (Functor, Applicative, Monad, - MonadFreshNames, HasScope lore, LocalScope lore, - MonadError RuleError) - -instance Fail.MonadFail (RuleM lore) where - fail = throwError . OtherError + MonadFreshNames, HasScope lore, LocalScope lore) instance (ASTLore lore, BinderOps lore) => MonadBinder (RuleM lore) where type Lore (RuleM lore) = lore @@ -84,20 +75,15 @@ collectStms (RuleM m) = RuleM $ collectStms m -- | Execute a 'RuleM' action. If succesful, returns the result and a --- list of new bindings. Even if the action fail, there may still be --- a monadic effect - particularly, the name source may have been --- modified. +-- list of new bindings. simplify :: Scope lore -> VNameSource -> Rule lore -> Maybe (Stms lore, VNameSource) simplify _ _ Skip = Nothing simplify scope src (Simplify (RuleM m)) = - case runExcept $ runStateT (runBinderT m scope) src of - Left CannotSimplify -> Nothing - Left (OtherError err) -> error $ "simplify: " ++ err - Right (((), x), src') -> Just (x, src') + runStateT (runBinderT_ m scope) src cannotSimplify :: RuleM lore a -cannotSimplify = throwError CannotSimplify +cannotSimplify = RuleM $ lift $ lift Nothing liftMaybe :: Maybe a -> RuleM lore a liftMaybe Nothing = cannotSimplify @@ -132,11 +118,11 @@ -- | A collection of rules grouped by which forms of statements they -- may apply to. data Rules lore a = Rules { rulesAny :: [SimplificationRule lore a] - , rulesBasicOp :: [SimplificationRule lore a] - , rulesIf :: [SimplificationRule lore a] - , rulesDoLoop :: [SimplificationRule lore a] - , rulesOp :: [SimplificationRule lore a] - } + , rulesBasicOp :: [SimplificationRule lore a] + , rulesIf :: [SimplificationRule lore a] + , rulesDoLoop :: [SimplificationRule lore a] + , rulesOp :: [SimplificationRule lore a] + } instance Semigroup (Rules lore a) where Rules as1 bs1 cs1 ds1 es1 <> Rules as2 bs2 cs2 ds2 es2 = 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 @@ -385,10 +385,15 @@ | Just res <- doBinOp op v1 v2 = constRes res -simplifyBinOp _ _ (BinOp Add{} e1 e2) +simplifyBinOp look _ (BinOp Add{} e1 e2) | isCt0 e1 = subExpRes e2 | isCt0 e2 = subExpRes e1 + -- x+(y-x) => y + | Var v2 <- e2, + Just (BasicOp (BinOp Sub{} e2_a e2_b), cs) <- look v2, + e2_b == e1 = Just (SubExp e2_a, cs) + simplifyBinOp _ _ (BinOp FAdd{} e1 e2) | isCt0 e1 = subExpRes e2 | isCt0 e2 = subExpRes e1 @@ -425,7 +430,7 @@ | isCt1 e1 = subExpRes e2 | isCt1 e2 = subExpRes e1 -simplifyBinOp look _ (BinOp (SMod t) e1 e2) +simplifyBinOp look _ (BinOp (SMod t _) e1 e2) | isCt1 e2 = constRes $ IntValue $ intValue t (0 :: Int) | e1 == e2 = constRes $ IntValue $ intValue t (0 :: Int) | Var v1 <- e1, @@ -437,12 +442,17 @@ | isCt1 e2 = subExpRes e1 | isCt0 e2 = Nothing +simplifyBinOp _ _ (BinOp SDivUp{} e1 e2) + | isCt0 e1 = subExpRes e1 + | isCt1 e2 = subExpRes e1 + | isCt0 e2 = Nothing + simplifyBinOp _ _ (BinOp FDiv{} e1 e2) | isCt0 e1 = subExpRes e1 | isCt1 e2 = subExpRes e1 | isCt0 e2 = Nothing -simplifyBinOp _ _ (BinOp (SRem t) e1 e2) +simplifyBinOp _ _ (BinOp (SRem t _) e1 e2) | isCt1 e2 = constRes $ IntValue $ intValue t (0 :: Int) | e1 == e2 = constRes $ IntValue $ intValue t (1 :: Int) @@ -656,7 +666,7 @@ dims <- arrayDims <$> lookupType a let adjustI i o d = do i_p_o <- letSubExp "i_p_o" $ BasicOp $ BinOp (Add Int32 OverflowWrap) i o - letSubExp "rot_i" (BasicOp $ BinOp (SMod Int32) i_p_o d) + letSubExp "rot_i" (BasicOp $ BinOp (SMod Int32 Unsafe) i_p_o d) adjust (DimFix i, o, d) = DimFix <$> adjustI i o d adjust (DimSlice i n s, o, d) = @@ -664,7 +674,8 @@ IndexResult cs a <$> mapM adjust (zip3 inds offsets dims) Just (Index aa ais, cs) -> - Just $ IndexResult cs aa <$> sliceSlice ais inds + Just $ IndexResult cs aa <$> + subExpSlice (sliceSlice (primExpSlice ais) (primExpSlice inds)) Just (Replicate (Shape [_]) (Var vv), cs) | [DimFix{}] <- inds, not consuming -> Just $ pure $ SubExpResult cs $ Var vv @@ -774,20 +785,6 @@ worthInlining' FunExp{} = False worthInlining' _ = True -sliceSlice :: MonadBinder m => - [DimIndex SubExp] -> [DimIndex SubExp] -> m [DimIndex SubExp] -sliceSlice (DimFix j:js') is' = (DimFix j:) <$> sliceSlice js' is' -sliceSlice (DimSlice j _ s:js') (DimFix i:is') = do - i_t_s <- letSubExp "j_t_s" $ BasicOp $ BinOp (Mul Int32 OverflowWrap) i s - j_p_i_t_s <- letSubExp "j_p_i_t_s" $ BasicOp $ BinOp (Add Int32 OverflowWrap) j i_t_s - (DimFix j_p_i_t_s:) <$> sliceSlice js' is' -sliceSlice (DimSlice j _ s0:js') (DimSlice i n s1:is') = do - s0_t_i <- letSubExp "s0_t_i" $ BasicOp $ BinOp (Mul Int32 OverflowWrap) s0 i - j_p_s0_t_i <- letSubExp "j_p_s0_t_i" $ BasicOp $ BinOp (Add Int32 OverflowWrap) j s0_t_i - (DimSlice j_p_s0_t_i n s1:) <$> sliceSlice js' is' -sliceSlice _ _ = return [] - - simplifyConcat :: BinderOps lore => BottomUpRuleBasicOp lore -- concat@1(transpose(x),transpose(y)) == transpose(concat@0(x,y)) @@ -1047,6 +1044,17 @@ | Just (BasicOp Scratch{}, _) <- ST.lookupExp v vtable = Simplify $ letBind pat $ BasicOp $ SubExp $ Var src +-- If we are writing a single-element slice from some array, and the +-- element of that array can be computed as a PrimExp based on the +-- index, let's just write that instead. +ruleBasicOp vtable pat aux (Update src [DimSlice i n s] (Var v)) + | isCt1 n, isCt1 s, + Just (ST.Indexed cs e) <- ST.index v [intConst Int32 0] vtable = + Simplify $ do + e' <- toSubExp "update_elem" e + auxing aux $ certifying cs $ + letBind pat $ BasicOp $ Update src [DimFix i] e' + ruleBasicOp vtable pat _ (Update dest destis (Var v)) | Just (e, _) <- ST.lookupExp v vtable, arrayFrom e = @@ -1085,7 +1093,7 @@ Just (Index v4 is4, cs4) <- ST.lookupBasicOp v3 vtable, is4 == is1, v4 == dest1 = Simplify $ certifying (cs1 <> cs2 <> cs3 <> cs4) $ do - is5 <- sliceSlice is1 is2 + is5 <- subExpSlice $ sliceSlice (primExpSlice is1) (primExpSlice is2) attributing attrs $ letBind pat $ BasicOp $ Update dest1 is5 se2 -- | If we are comparing X against the result of a branch of the form @@ -1099,7 +1107,7 @@ | Just m <- simplifyWith se1 se2 = Simplify m | Just m <- simplifyWith se2 se1 = Simplify m where simplifyWith (Var v) x - | Just bnd <- ST.entryStm =<< ST.lookup v vtable, + | Just bnd <- ST.lookupStm v vtable, If p tbranch fbranch _ <- stmExp bnd, Just (y, z) <- returns v (stmPattern bnd) tbranch fbranch, @@ -1240,6 +1248,26 @@ v' <- letExp (baseString v ++ "_slice") $ BasicOp $ Index arr_y slice_y' certifying cs_y $ auxing aux $ letBind pat $ BasicOp $ Update arr_x slice_x' $ Var v' + +-- Simplify away 0<=i when 'i' is from a loop of form 'for i < n'. +ruleBasicOp vtable pat aux (CmpOp CmpSle{} x y) + | Constant (IntValue (Int32Value 0)) <- x, + Var v <- y, + Just _ <- ST.lookupLoopVar v vtable = + Simplify $ auxing aux $ letBind pat $ BasicOp $ SubExp $ constant True + +-- Simplify away i do @@ -72,10 +72,10 @@ where isSimpleResult (Returns _ se) = Just se isSimpleResult _ = Nothing -tileInBody :: Names -> VarianceTable +tileInBody :: Names -> Names -> VarianceTable -> SegLevel -> SegSpace -> [Type] -> Body Kernels -> TileM (Maybe (Stms Kernels, Tiling, TiledBody)) -tileInBody branch_variant initial_variance initial_lvl initial_space res_ts (Body () initial_kstms stms_res) = +tileInBody branch_variant private initial_variance initial_lvl initial_space res_ts (Body () initial_kstms stms_res) = descend mempty $ stmsToList initial_kstms where variance = varianceInStms initial_variance initial_kstms @@ -95,7 +95,7 @@ preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms), used <- freeIn stm_to_tile <> freeIn stms_res = - Just . injectPrelude initial_space variance prestms' used <$> + Just . injectPrelude initial_space private variance prestms' used <$> tileGeneric (tiling1d $ reverse top_space_rev) initial_lvl res_ts (stmPattern stm_to_tile) gtid kdim @@ -111,7 +111,7 @@ preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms), used <- freeIn stm_to_tile <> freeIn stms_res = - Just . injectPrelude initial_space variance prestms' used <$> + Just . injectPrelude initial_space private variance prestms' used <$> tileGeneric (tiling2d $ reverse $ zip top_gtids_rev top_kdims_rev) initial_lvl res_ts (stmPattern stm_to_tile) (gtid_x, gtid_y) (kdim_x, kdim_y) @@ -127,10 +127,11 @@ mconcat (map (flip (M.findWithDefault mempty) variance) (namesToList (freeIn bound))) merge_params = map fst merge + private' = namesFromList $ map paramName merge_params maybe_tiled <- localScope (M.insert i (IndexName it) $ scopeOfFParams merge_params) $ - tileInBody branch_variant' variance initial_lvl initial_space + tileInBody branch_variant' private' variance initial_lvl initial_space (map paramType merge_params) $ mkBody (bodyStms loopbody) (bodyResult loopbody) case maybe_tiled of @@ -183,7 +184,7 @@ -- be manifested in memory). partitionPrelude :: VarianceTable -> Stms Kernels -> Names -> (Stms Kernels, Stms Kernels, Stms Kernels) -partitionPrelude variance prestms tiled_kdims = +partitionPrelude variance prestms private = (invariant_prestms, precomputed_variant_prestms, recomputed_variant_prestms) where invariantTo names stm = @@ -192,7 +193,7 @@ v:_ -> not $ any (`nameIn` names) $ namesToList $ M.findWithDefault mempty v variance (invariant_prestms, variant_prestms) = - Seq.partition (invariantTo tiled_kdims) prestms + Seq.partition (invariantTo private) prestms mustBeInlinedExp (BasicOp (Index _ slice)) = not $ null $ sliceDims slice mustBeInlinedExp (BasicOp Rotate{}) = True @@ -209,21 +210,24 @@ (recomputed_variant_prestms, precomputed_variant_prestms) = Seq.partition recompute variant_prestms -injectPrelude :: SegSpace -> VarianceTable +-- Anything that is variant to the "private" names should be +-- considered thread-local. +injectPrelude :: SegSpace -> Names -> VarianceTable -> Stms Kernels -> Names -> (Stms Kernels, Tiling, TiledBody) -> (Stms Kernels, Tiling, TiledBody) -injectPrelude initial_space variance prestms used (host_stms, tiling, tiledBody) = +injectPrelude initial_space private variance prestms used (host_stms, tiling, tiledBody) = (host_stms, tiling, tiledBody') - where tiled_kdims = namesFromList $ map fst $ - filter (`notElem` unSegSpace (tilingSpace tiling)) $ - unSegSpace initial_space + where private' = private <> namesFromList + (map fst $ + filter (`notElem` unSegSpace (tilingSpace tiling)) $ + unSegSpace initial_space) tiledBody' privstms = do let (invariant_prestms, precomputed_variant_prestms, recomputed_variant_prestms) = - partitionPrelude variance prestms tiled_kdims + partitionPrelude variance prestms private' addStms invariant_prestms @@ -291,7 +295,7 @@ fullSlice (paramType from) slice loopbody' <- runBodyBinder $ resultBody . map Var <$> - tiledBody (privstms <> inloop_privstms <> PrivStms mempty indexMergeParams) + tiledBody (PrivStms mempty indexMergeParams <> privstms <> inloop_privstms) accs' <- letTupExp "tiled_inside_loop" $ DoLoop [] merge' (ForLoop i it bound []) loopbody' @@ -393,7 +397,7 @@ , tilingLevel :: SegLevel - , tilingNumWholeTiles :: SubExp + , tilingNumWholeTiles :: Binder Kernels SubExp } type DoTiling gtids kdims = @@ -416,8 +420,9 @@ postludeGeneric tiling privstms pat accs' poststms poststms_res res_ts = tilingSegMap tiling "thread_res" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> do -- Read our per-thread result from the tiled loop. - forM_ (zip (patternNames pat) accs') $ \(us, everyone) -> - letBindNames [us] $ BasicOp $ Index everyone slice + forM_ (zip (patternNames pat) accs') $ \(us, everyone) -> do + everyone_t <- lookupType everyone + letBindNames [us] $ BasicOp $ Index everyone $ fullSlice everyone_t slice if poststms == mempty then do -- The privstms may still be necessary for the result. @@ -454,9 +459,10 @@ tiledBody :: Tiling -> PrivStms -> Binder Kernels [VName] tiledBody tiling privstms = do - let num_whole_tiles = tilingNumWholeTiles tiling - tile_shape = tilingTileShape tiling + let tile_shape = tilingTileShape tiling + num_whole_tiles <- tilingNumWholeTiles tiling + -- We don't use a Replicate here, because we want to enforce a -- scalar memory space. mergeinits <- tilingSegMap tiling "mergeinit" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> @@ -622,7 +628,7 @@ -- The number of residual elements that are not covered by -- the whole tiles. residual_input <- letSubExp "residual_input" $ - BasicOp $ BinOp (SRem Int32) w tile_size + BasicOp $ BinOp (SRem Int32 Unsafe) w tile_size letTupExp "acc_after_residual" =<< eIf (toExp $ primExpFromSubExp int32 residual_input .==. 0) @@ -659,8 +665,8 @@ BasicOp $ BinOp (SMin Int32) (unCount (segGroupSize initial_lvl)) kdim -- How many groups we need to exhaust the innermost dimension. - ldim <- letSubExp "ldim" =<< - eDivRoundingUp Int32 (eSubExp kdim) (eSubExp group_size) + ldim <- letSubExp "ldim" $ + BasicOp $ BinOp (SDivUp Int32 Unsafe) kdim group_size num_groups <- letSubExp "computed_num_groups" =<< foldBinOp (Mul Int32 OverflowUndef) ldim (map snd dims_on_top) @@ -669,8 +675,7 @@ SegSpace gid_flat $ dims_on_top ++ [(gid, ldim)]) let tile_size = unCount $ segGroupSize lvl - -- Number of whole tiles that fit in the input. - num_whole_tiles <- letSubExp "num_whole_tiles" $ BasicOp $ BinOp (SQuot Int32) w tile_size + return Tiling { tilingSegMap = \desc lvl' manifest f -> segMap1D desc lvl' manifest $ \ltid -> do letBindNames [gtid] =<< @@ -691,7 +696,8 @@ , tilingTileReturns = tileReturns dims_on_top [(kdim, tile_size)] , tilingTileShape = Shape [tile_size] - , tilingNumWholeTiles = num_whole_tiles + , tilingNumWholeTiles = letSubExp "num_whole_tiles" $ + BasicOp $ BinOp (SQuot Int32 Unsafe) w tile_size , tilingLevel = lvl , tilingSpace = space } @@ -836,7 +842,7 @@ -- The number of residual elements that are not covered by -- the whole tiles. residual_input <- letSubExp "residual_input" $ - BasicOp $ BinOp (SRem Int32) w tile_size + BasicOp $ BinOp (SRem Int32 Unsafe) w tile_size letTupExp "acc_after_residual" =<< eIf (toExp $ primExpFromSubExp int32 residual_input .==. 0) @@ -871,10 +877,10 @@ tile_size <- letSubExp "tile_size" $ Op $ SizeOp $ GetSize tile_size_key SizeTile group_size <- letSubExp "group_size" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) tile_size tile_size - num_groups_x <- letSubExp "num_groups_x" =<< - eDivRoundingUp Int32 (eSubExp kdim_x) (eSubExp tile_size) - num_groups_y <- letSubExp "num_groups_y" =<< - eDivRoundingUp Int32 (eSubExp kdim_y) (eSubExp tile_size) + num_groups_x <- letSubExp "num_groups_x" $ + BasicOp $ BinOp (SDivUp Int32 Unsafe) kdim_x tile_size + num_groups_y <- letSubExp "num_groups_y" $ + BasicOp $ BinOp (SDivUp Int32 Unsafe) kdim_y tile_size num_groups <- letSubExp "num_groups_top" =<< foldBinOp (Mul Int32 OverflowUndef) num_groups_x @@ -885,9 +891,6 @@ space = SegSpace gid_flat $ dims_on_top ++ [(gid_x, num_groups_x), (gid_y, num_groups_y)] - -- Number of whole tiles that fit in the input. - num_whole_tiles <- letSubExp "num_whole_tiles" $ - BasicOp $ BinOp (SQuot Int32) w tile_size return Tiling { tilingSegMap = \desc lvl' manifest f -> segMap2D desc lvl' manifest (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do @@ -903,7 +906,8 @@ , tilingTileReturns = tileReturns dims_on_top [(kdim_x, tile_size), (kdim_y, tile_size)] , tilingTileShape = Shape [tile_size, tile_size] - , tilingNumWholeTiles = num_whole_tiles + , tilingNumWholeTiles = letSubExp "num_whole_tiles" $ + BasicOp $ BinOp (SQuot Int32 Unsafe) w tile_size , tilingLevel = lvl , tilingSpace = space } diff --git a/src/Futhark/Optimise/Unstream.hs b/src/Futhark/Optimise/Unstream.hs --- a/src/Futhark/Optimise/Unstream.hs +++ b/src/Futhark/Optimise/Unstream.hs @@ -3,6 +3,20 @@ -- | Sequentialise any remaining SOACs. It is very important that -- this is run *after* any access-pattern-related optimisation, -- because this pass will destroy information. +-- +-- This pass conceptually contains three subpasses: +-- +-- 1. Sequentialise 'Stream' operations, leaving other SOACs intact. +-- +-- 2. Apply whole-program simplification. +-- +-- 3. Sequentialise remaining SOACs. +-- +-- This is because sequentialisation of streams creates many SOACs +-- operating on single-element arrays, which can be efficiently +-- simplified away, but only *before* they are turned into loops. In +-- principle this pass could be split into multiple, but for now it is +-- kept together. module Futhark.Optimise.Unstream (unstream) where import Control.Monad.State @@ -10,51 +24,68 @@ import Futhark.MonadFreshNames import Futhark.IR.Kernels +import Futhark.IR.Kernels.Simplify (simplifyKernels) import Futhark.Pass import Futhark.Tools import qualified Futhark.Transform.FirstOrderTransform as FOT +data Stage = SeqStreams | SeqAll + -- | The pass definition. unstream :: Pass Kernels Kernels unstream = Pass "unstream" "sequentialise remaining SOACs" $ - intraproceduralTransformation optimise - where optimise scope stms = - modifyNameSource $ runState $ runReaderT (optimiseStms stms) scope + intraproceduralTransformation (optimise SeqStreams) + >=> simplifyKernels + >=> intraproceduralTransformation (optimise SeqAll) + where optimise stage scope stms = + modifyNameSource $ runState $ runReaderT (optimiseStms stage stms) scope type UnstreamM = ReaderT (Scope Kernels) (State VNameSource) -optimiseStms :: Stms Kernels -> UnstreamM (Stms Kernels) -optimiseStms stms = +optimiseStms :: Stage -> Stms Kernels -> UnstreamM (Stms Kernels) +optimiseStms stage stms = localScope (scopeOf stms) $ - stmsFromList . concat <$> mapM optimiseStm (stmsToList stms) + stmsFromList . concat <$> mapM (optimiseStm stage) (stmsToList stms) -optimiseBody :: Body Kernels -> UnstreamM (Body Kernels) -optimiseBody (Body () stms res) = - Body () <$> optimiseStms stms <*> pure res +optimiseBody :: Stage -> Body Kernels -> UnstreamM (Body Kernels) +optimiseBody stage (Body () stms res) = + Body () <$> optimiseStms stage stms <*> pure res -optimiseKernelBody :: KernelBody Kernels -> UnstreamM (KernelBody Kernels) -optimiseKernelBody (KernelBody () stms res) = +optimiseKernelBody :: Stage -> KernelBody Kernels -> UnstreamM (KernelBody Kernels) +optimiseKernelBody stage (KernelBody () stms res) = localScope (scopeOf stms) $ - KernelBody () <$> (stmsFromList . concat <$> mapM optimiseStm (stmsToList stms)) <*> pure res + KernelBody () + <$> (stmsFromList . concat <$> mapM (optimiseStm stage) (stmsToList stms)) + <*> pure res -optimiseLambda :: Lambda Kernels -> UnstreamM (Lambda Kernels) -optimiseLambda lam = localScope (scopeOfLParams $ lambdaParams lam) $ do - body <- optimiseBody $ lambdaBody lam - return lam { lambdaBody = body} +optimiseLambda :: Stage -> Lambda Kernels -> UnstreamM (Lambda Kernels) +optimiseLambda stage lam = localScope (scopeOfLParams $ lambdaParams lam) $ do + body <- optimiseBody stage $ lambdaBody lam + return lam { lambdaBody = body } -optimiseStm :: Stm Kernels -> UnstreamM [Stm Kernels] +sequentialise :: Stage -> SOAC Kernels -> Bool +sequentialise SeqStreams Stream{} = True +sequentialise SeqStreams _ = False +sequentialise SeqAll _ = True -optimiseStm (Let pat _ (Op (OtherOp soac))) = do - stms <- runBinder_ $ FOT.transformSOAC pat soac - fmap concat $ localScope (scopeOf stms) $ mapM optimiseStm $ stmsToList stms +optimiseStm :: Stage -> Stm Kernels -> UnstreamM [Stm Kernels] -optimiseStm (Let pat aux (Op (SegOp op))) = +optimiseStm stage (Let pat aux (Op (OtherOp soac))) + | sequentialise stage soac = do + stms <- runBinder_ $ FOT.transformSOAC pat soac + fmap concat $ localScope (scopeOf stms) $ mapM (optimiseStm stage) $ stmsToList stms + | otherwise = do + -- Still sequentialise whatever's inside. + pure <$> (Let pat aux . Op . OtherOp <$> mapSOACM optimise soac) + where optimise = identitySOACMapper { mapOnSOACLambda = optimiseLambda stage } + +optimiseStm stage (Let pat aux (Op (SegOp op))) = localScope (scopeOfSegSpace $ segSpace op) $ pure <$> (Let pat aux . Op . SegOp <$> mapSegOpM optimise op) - where optimise = identitySegOpMapper { mapOnSegOpBody = optimiseKernelBody - , mapOnSegOpLambda = optimiseLambda + where optimise = identitySegOpMapper { mapOnSegOpBody = optimiseKernelBody stage + , mapOnSegOpLambda = optimiseLambda stage } -optimiseStm (Let pat aux e) = +optimiseStm stage (Let pat aux e) = pure <$> (Let pat aux <$> mapExpM optimise e) - where optimise = identityMapper { mapOnBody = \scope -> localScope scope . optimiseBody } + where optimise = identityMapper { mapOnBody = \scope -> localScope scope . optimiseBody stage } 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 @@ -22,7 +22,7 @@ import Futhark.Pass import Futhark.IR import Futhark.IR.KernelsMem -import Futhark.IR.Kernels.Simplify as Kernels +import qualified Futhark.IR.Kernels.Simplify as Kernels import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Pass.ExtractKernels.BlockedKernel (nonSegRed) import Futhark.Pass.ExtractKernels.ToKernels (segThread) @@ -142,12 +142,12 @@ transformScanRed lvl space ops kbody = do bound_outside <- asks $ namesFromList . M.keys let (kbody', kbody_allocs) = - extractKernelBodyAllocations bound_outside bound_in_kernel kbody - (ops', ops_allocs) = unzip $ map (extractLambdaAllocations bound_outside mempty) ops - variantAlloc (Var v) = v `nameIn` bound_in_kernel + extractKernelBodyAllocations lvl bound_outside bound_in_kernel kbody + (ops', ops_allocs) = unzip $ map (extractLambdaAllocations lvl bound_outside mempty) ops + variantAlloc (_, Var v, _) = v `nameIn` bound_in_kernel variantAlloc _ = False allocs = kbody_allocs <> mconcat ops_allocs - (variant_allocs, invariant_allocs) = M.partition (variantAlloc . fst) allocs + (variant_allocs, invariant_allocs) = M.partition variantAlloc allocs case lvl of SegGroup{} @@ -164,8 +164,8 @@ where bound_in_kernel = namesFromList $ M.keys $ scopeOfSegSpace space <> scopeOf (kernelBodyStms kbody) -allocsForBody :: M.Map VName (SubExp, Space) - -> M.Map VName (SubExp, Space) +allocsForBody :: Extraction + -> Extraction -> SegLevel -> SegSpace -> KernelBody KernelsMem -> (Stms KernelsMem -> KernelBody KernelsMem -> OffsetM b) @@ -183,58 +183,60 @@ memoryRequirements :: SegLevel -> SegSpace -> Stms KernelsMem - -> M.Map VName (SubExp, Space) - -> M.Map VName (SubExp, Space) + -> Extraction -> Extraction -> ExpandM (RebaseMap, Stms KernelsMem) memoryRequirements lvl space kstms variant_allocs invariant_allocs = do - ((num_threads, num_threads64), num_threads_stms) <- runBinder $ do + ((num_threads, num_groups64, num_threads64), num_threads_stms) <- runBinder $ do num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) (unCount $ segNumGroups lvl) (unCount $ segGroupSize lvl) + num_groups64 <- letSubExp "num_groups64" $ + BasicOp $ ConvOp (SExt Int32 Int64) (unCount $ segNumGroups lvl) num_threads64 <- letSubExp "num_threads64" $ BasicOp $ ConvOp (SExt Int32 Int64) num_threads - return (num_threads, num_threads64) + return (num_threads, num_groups64, num_threads64) (invariant_alloc_stms, invariant_alloc_offsets) <- inScopeOf num_threads_stms $ expandedInvariantAllocations - (num_threads64, segNumGroups lvl, segGroupSize lvl) + (num_threads64, num_groups64, segNumGroups lvl, segGroupSize lvl) space invariant_allocs (variant_alloc_stms, variant_alloc_offsets) <- - inScopeOf num_threads_stms $ expandedVariantAllocations num_threads space kstms variant_allocs + inScopeOf num_threads_stms $ expandedVariantAllocations + num_threads space kstms variant_allocs return (invariant_alloc_offsets <> variant_alloc_offsets, num_threads_stms <> invariant_alloc_stms <> variant_alloc_stms) -- | A description of allocations that have been extracted, and how -- much memory (and which space) is needed. -type Extraction = M.Map VName (SubExp, Space) +type Extraction = M.Map VName (SegLevel, SubExp, Space) -extractKernelBodyAllocations :: Names -> Names -> KernelBody KernelsMem +extractKernelBodyAllocations :: SegLevel -> Names -> Names -> KernelBody KernelsMem -> (KernelBody KernelsMem, Extraction) -extractKernelBodyAllocations bound_outside bound_kernel = - extractGenericBodyAllocations bound_outside bound_kernel kernelBodyStms $ +extractKernelBodyAllocations lvl bound_outside bound_kernel = + extractGenericBodyAllocations lvl bound_outside bound_kernel kernelBodyStms $ \stms kbody -> kbody { kernelBodyStms = stms } -extractBodyAllocations :: Names -> Names -> Body KernelsMem +extractBodyAllocations :: SegLevel -> Names -> Names -> Body KernelsMem -> (Body KernelsMem, Extraction) -extractBodyAllocations bound_outside bound_kernel = - extractGenericBodyAllocations bound_outside bound_kernel bodyStms $ +extractBodyAllocations lvl bound_outside bound_kernel = + extractGenericBodyAllocations lvl bound_outside bound_kernel bodyStms $ \stms body -> body { bodyStms = stms } -extractLambdaAllocations :: Names -> Names -> Lambda KernelsMem +extractLambdaAllocations :: SegLevel -> Names -> Names -> Lambda KernelsMem -> (Lambda KernelsMem, Extraction) -extractLambdaAllocations bound_outside bound_kernel lam = (lam { lambdaBody = body' }, allocs) - where (body', allocs) = extractBodyAllocations bound_outside bound_kernel $ lambdaBody lam +extractLambdaAllocations lvl bound_outside bound_kernel lam = (lam { lambdaBody = body' }, allocs) + where (body', allocs) = extractBodyAllocations lvl bound_outside bound_kernel $ lambdaBody lam -extractGenericBodyAllocations :: Names -> Names +extractGenericBodyAllocations :: SegLevel -> Names -> Names -> (body -> Stms KernelsMem) -> (Stms KernelsMem -> body -> body) -> body -> (body, Extraction) -extractGenericBodyAllocations bound_outside bound_kernel get_stms set_stms body = +extractGenericBodyAllocations lvl bound_outside bound_kernel get_stms set_stms body = let (stms, allocs) = runWriter $ fmap catMaybes $ - mapM (extractStmAllocations bound_outside bound_kernel) $ + mapM (extractStmAllocations lvl bound_outside bound_kernel) $ stmsToList $ get_stms body in (set_stms (stmsFromList stms) body, allocs) @@ -243,11 +245,11 @@ expandable ScalarSpace{} = False expandable _ = True -extractStmAllocations :: Names -> Names -> Stm KernelsMem +extractStmAllocations :: SegLevel -> Names -> Names -> Stm KernelsMem -> Writer Extraction (Maybe (Stm KernelsMem)) -extractStmAllocations bound_outside bound_kernel (Let (Pattern [] [patElem]) _ (Op (Alloc size space))) +extractStmAllocations lvl bound_outside bound_kernel (Let (Pattern [] [patElem]) _ (Op (Alloc size space))) | expandable space && expandableSize size || boundInKernel size = do - tell $ M.singleton (patElemName patElem) (size, space) + tell $ M.singleton (patElemName patElem) (lvl, size, space) return Nothing where expandableSize (Var v) = v `nameIn` bound_outside || v `nameIn` bound_kernel @@ -255,38 +257,42 @@ boundInKernel (Var v) = v `nameIn` bound_kernel boundInKernel Constant{} = False -extractStmAllocations bound_outside bound_kernel stm = do - e <- mapExpM expMapper $ stmExp stm +extractStmAllocations lvl bound_outside bound_kernel stm = do + e <- mapExpM (expMapper lvl) $ stmExp stm return $ Just $ stm { stmExp = e } - where expMapper = identityMapper { mapOnBody = const onBody - , mapOnOp = onOp } + where expMapper lvl' = identityMapper { mapOnBody = const $ onBody lvl' + , mapOnOp = onOp + } - onBody body = do - let (body', allocs) = extractBodyAllocations bound_outside bound_kernel body + onBody lvl' body = do + let (body', allocs) = extractBodyAllocations lvl' bound_outside bound_kernel body tell allocs return body' - onOp (Inner (SegOp op)) = Inner . SegOp <$> mapSegOpM opMapper op + onOp (Inner (SegOp op)) = + Inner . SegOp <$> mapSegOpM (opMapper (segLevel op)) op onOp op = return op - opMapper = identitySegOpMapper { mapOnSegOpLambda = onLambda - , mapOnSegOpBody = onKernelBody - } + opMapper lvl' = identitySegOpMapper { mapOnSegOpLambda = onLambda lvl' + , mapOnSegOpBody = onKernelBody lvl' + } - onKernelBody body = do - let (body', allocs) = extractKernelBodyAllocations bound_outside bound_kernel body + onKernelBody lvl' body = do + let (body', allocs) = extractKernelBodyAllocations lvl' bound_outside bound_kernel body tell allocs return body' - onLambda lam = do - body <- onBody $ lambdaBody lam + onLambda lvl' lam = do + body <- onBody lvl' $ lambdaBody lam return lam { lambdaBody = body } -expandedInvariantAllocations :: (SubExp, Count NumGroups SubExp, Count GroupSize SubExp) +expandedInvariantAllocations :: (SubExp, SubExp, + Count NumGroups SubExp, Count GroupSize SubExp) -> SegSpace -> Extraction -> ExpandM (Stms KernelsMem, RebaseMap) -expandedInvariantAllocations (num_threads64, Count num_groups, Count group_size) +expandedInvariantAllocations (num_threads64, num_groups64, + Count num_groups, Count group_size) segspace invariant_allocs = do -- We expand the invariant allocations by adding an inner dimension @@ -294,30 +300,41 @@ (alloc_bnds, rebases) <- unzip <$> mapM expand (M.toList invariant_allocs) return (mconcat alloc_bnds, mconcat rebases) - where expand (mem, (per_thread_size, space)) = do + where expand (mem, (lvl, per_thread_size, space)) = do total_size <- newVName "total_size" let sizepat = Pattern [] [PatElem total_size $ MemPrim int64] allocpat = Pattern [] [PatElem mem $ MemMem space] + num_users = case lvl of SegThread{} -> num_threads64 + SegGroup{} -> num_groups64 return (stmsFromList [Let sizepat (defAux ()) $ - BasicOp $ BinOp (Mul Int64 OverflowUndef) num_threads64 per_thread_size, + BasicOp $ BinOp (Mul Int64 OverflowUndef) num_users per_thread_size, Let allocpat (defAux ()) $ Op $ Alloc (Var total_size) space], - M.singleton mem newBase) + M.singleton mem $ newBase lvl) - newBase (old_shape, _) = + untouched d = DimSlice (fromInt32 0) d (fromInt32 1) + + newBase SegThread{} (old_shape, _) = let num_dims = length old_shape perm = num_dims : [0..num_dims-1] root_ixfun = IxFun.iota (old_shape ++ [primExpFromSubExp int32 num_groups * primExpFromSubExp int32 group_size]) permuted_ixfun = IxFun.permute root_ixfun perm - untouched d = DimSlice (fromInt32 0) d (fromInt32 1) offset_ixfun = IxFun.slice permuted_ixfun $ DimFix (LeafExp (segFlat segspace) int32) : map untouched old_shape in offset_ixfun + newBase SegGroup{} (old_shape, _) = + let root_ixfun = IxFun.iota (primExpFromSubExp int32 num_groups : old_shape) + offset_ixfun = IxFun.slice root_ixfun $ + DimFix (LeafExp (segFlat segspace) int32) : + map untouched old_shape + in offset_ixfun + + expandedVariantAllocations :: SubExp -> SegSpace -> Stms KernelsMem -> Extraction @@ -573,7 +590,7 @@ removeCommonSizes :: Extraction -> [(SubExp, [(VName, Space)])] removeCommonSizes = M.toList . foldl' comb mempty . M.toList - where comb m (mem, (size, space)) = M.insertWith (++) size [(mem, space)] m + where comb m (mem, (_, size, space)) = M.insertWith (++) size [(mem, space)] m sliceKernelSizes :: SubExp -> [SubExp] -> SegSpace -> Stms KernelsMem -> ExpandM (Stms Kernels.Kernels, [VName], [VName]) @@ -612,7 +629,7 @@ return sizes localScope (scopeOfSegSpace space) $ - Kernels.simplifyLambda (Lambda [flat_gtid_lparam] (Body () stms zs) i64s) [] + Kernels.simplifyLambda (Lambda [flat_gtid_lparam] (Body () stms zs) i64s) ((maxes_per_thread, size_sums), slice_stms) <- flip runBinderT kernels_scope $ do num_threads_64 <- letSubExp "num_threads" $ diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs --- a/src/Futhark/Pass/ExplicitAllocations.hs +++ b/src/Futhark/Pass/ExplicitAllocations.hs @@ -50,6 +50,7 @@ import Data.Maybe import Data.List (zip4, partition, sort) +import qualified Futhark.Analysis.UsageTable as UT import Futhark.Optimise.Simplify.Lore (mkWiseBody) import Futhark.MonadFreshNames import Futhark.IR.Mem @@ -178,8 +179,8 @@ mkBodyM bnds res = return $ Body () bnds res - addStms binding = AllocM $ addBinderStms binding - collectStms (AllocM m) = AllocM $ collectBinderStms m + addStms = AllocM . addStms + collectStms (AllocM m) = AllocM $ collectStms m instance (Allocable fromlore tolore) => Allocator tolore (AllocM fromlore tolore) where @@ -390,24 +391,25 @@ directIxFun :: PrimType -> Shape -> u -> VName -> Type -> MemBound u directIxFun bt shape u mem t = - MemArray bt shape u $ ArrayIn mem $ - IxFun.iota $ map (primExpFromSubExp int32) $ arrayDims t + let ixf = IxFun.iota $ map (primExpFromSubExp int32) $ arrayDims t + in MemArray bt shape u $ ArrayIn mem ixf + allocInFParams :: (Allocable fromlore tolore) => [(FParam fromlore, Space)] -> ([FParam tolore] -> AllocM fromlore tolore a) -> AllocM fromlore tolore a allocInFParams params m = do - (valparams, memparams) <- + (valparams, (ctxparams, memparams)) <- runWriterT $ mapM (uncurry allocInFParam) params - let params' = memparams <> valparams + let params' = ctxparams <> memparams <> valparams summary = scopeOfFParams params' localScope summary $ m params' allocInFParam :: (Allocable fromlore tolore) => FParam fromlore -> Space - -> WriterT [FParam tolore] + -> WriterT ([FParam tolore], [FParam tolore]) (AllocM fromlore tolore) (FParam tolore) allocInFParam param pspace = case paramDeclType param of @@ -415,7 +417,7 @@ let memname = baseString (paramName param) <> "_mem" ixfun = IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape mem <- lift $ newVName memname - tell [Param mem $ MemMem pspace] + tell ([], [Param mem $ MemMem pspace]) return param { paramDec = MemArray bt shape u $ ArrayIn mem ixfun } Prim bt -> return param { paramDec = MemPrim bt } @@ -424,66 +426,104 @@ allocInMergeParams :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => - [VName] - -> [(FParam fromlore,SubExp)] + [(FParam fromlore,SubExp)] -> ([FParam tolore] -> [FParam tolore] -> ([SubExp] -> AllocM fromlore tolore ([SubExp], [SubExp])) -> AllocM fromlore tolore a) -> AllocM fromlore tolore a -allocInMergeParams variant merge m = do - ((valparams, handle_loop_subexps), mem_params) <- +allocInMergeParams merge m = do + ((valparams, handle_loop_subexps), (ctx_params, mem_params)) <- runWriterT $ unzip <$> mapM allocInMergeParam merge - let mergeparams' = mem_params <> valparams + let mergeparams' = ctx_params <> mem_params <> valparams summary = scopeOfFParams mergeparams' mk_loop_res ses = do - (valargs, memargs) <- + (valargs, (ctxargs, memargs)) <- runWriterT $ zipWithM ($) handle_loop_subexps ses - return (memargs, valargs) + return (ctxargs <> memargs, valargs) - localScope summary $ m mem_params valparams mk_loop_res - where allocInMergeParam (mergeparam, Var v) - | Array bt shape u <- paramDeclType mergeparam = do - (mem, ixfun) <- lift $ lookupArraySummary v - space <- lift $ lookupMemSpace mem - reuse <- asks aggressiveReuse - if space /= Space "local" && - reuse && - u == Unique && - loopInvariantShape mergeparam - then return (mergeparam { paramDec = MemArray bt shape Unique $ ArrayIn mem ixfun }, - lift . ensureArrayIn (paramType mergeparam) mem ixfun) - else do def_space <- asks allocSpace - doDefault mergeparam def_space + localScope summary $ m (ctx_params <> mem_params) valparams mk_loop_res + where + allocInMergeParam :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => + (Param DeclType, SubExp) -> + WriterT + ([FParam tolore], [FParam tolore]) + (AllocM fromlore tolore) + (FParam tolore, SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromlore tolore) SubExp) + allocInMergeParam (mergeparam, Var v) + | Array bt shape u <- paramDeclType mergeparam = do + (mem', _) <- lift $ lookupArraySummary v + mem_space <- lift $ lookupMemSpace mem' - allocInMergeParam (mergeparam, _) = doDefault mergeparam =<< lift askDefaultSpace + (_, ext_ixfun, substs, _) <- lift $ existentializeArray mem_space v - doDefault mergeparam space = do - mergeparam' <- allocInFParam mergeparam space - return (mergeparam', linearFuncallArg (paramType mergeparam) space) + (ctx_params, param_ixfun_substs) <- + unzip <$> + mapM (\primExp -> do + let pt = primExpType primExp + vname <- lift $ newVName "ctx_param_ext" + return (Param vname $ MemPrim pt, + fmap Free $ primExpFromSubExp int32 $ Var vname)) + substs - variant_names = variant ++ map (paramName . fst) merge - loopInvariantShape = - not . any (`elem` variant_names) . subExpVars . arrayDims . paramType + tell (ctx_params, []) + param_ixfun <- instantiateIxFun $ + IxFun.substituteInIxFun (M.fromList $ zip (fmap Ext [0..]) param_ixfun_substs) + ext_ixfun + + mem_name <- newVName "mem_param" + tell ([], [Param mem_name $ MemMem mem_space]) + + return (mergeparam { paramDec = MemArray bt shape u $ ArrayIn mem_name param_ixfun }, + ensureArrayIn mem_space) + + allocInMergeParam (mergeparam, _) = doDefault mergeparam =<< lift askDefaultSpace + + doDefault mergeparam space = do + mergeparam' <- allocInFParam mergeparam space + return (mergeparam', linearFuncallArg (paramType mergeparam) space) + + +-- Returns the existentialized index function, the list of substituted values and the memory location. +existentializeArray :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => + Space -> VName -> AllocM fromlore tolore (SubExp, ExtIxFun, [PrimExp VName], VName) +existentializeArray space v = do + (mem', ixfun) <- lookupArraySummary v + sp <- lookupMemSpace mem' + + let (ext_ixfun', substs') = runState (IxFun.existentialize ixfun) [] + + case (ext_ixfun', sp == space) of + (Just x, True) -> return (Var v, x, substs', mem') + _ -> do + (mem, subexp) <- allocLinearArray space (baseString v) v + ixfun' <- fromJust <$> subExpIxFun subexp + let (ext_ixfun, substs) = runState (IxFun.existentialize ixfun') [] + return (subexp, fromJust ext_ixfun, substs, mem) + + + ensureArrayIn :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => - Type -> VName -> IxFun -> SubExp - -> AllocM fromlore tolore SubExp -ensureArrayIn _ _ _ (Constant v) = + Space -> SubExp + -> WriterT ([SubExp], [SubExp]) (AllocM fromlore tolore) SubExp +ensureArrayIn _ (Constant v) = error $ "ensureArrayIn: " ++ pretty v ++ " cannot be an array." -ensureArrayIn t mem ixfun (Var v) = do - (src_mem, src_ixfun) <- lookupArraySummary v - if src_mem == mem && src_ixfun == ixfun - then return $ Var v - else do copy <- newIdent (baseString v ++ "_ensure_copy") t - let summary = MemArray (elemType t) (arrayShape t) NoUniqueness $ - ArrayIn mem ixfun - pat = Pattern [] [PatElem (identName copy) summary] - letBind pat $ BasicOp $ Copy v - return $ Var $ identName copy +ensureArrayIn space (Var v) = do + (sub_exp, _, substs, mem) <- lift $ existentializeArray space v + (ctx_vals, _) <- + unzip <$> + mapM (\s -> do + vname <- lift $ letExp "ctx_val" =<< toExp s + return (Var vname, fmap Free $ primExpFromSubExp int32 $ Var vname)) + substs + tell (ctx_vals, [Var mem]) + + return sub_exp + ensureDirectArray :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => Maybe Space -> VName -> AllocM fromlore tolore (VName, SubExp) @@ -506,9 +546,8 @@ t <- lookupType v mem <- allocForArray t space v' <- newIdent (s ++ "_linear") t - let pat = Pattern [] [PatElem (identName v') $ - directIxFun (elemType t) (arrayShape t) - NoUniqueness mem t] + let ixfun = directIxFun (elemType t) (arrayShape t) NoUniqueness mem t + let pat = Pattern [] [PatElem (identName v') ixfun] addStm $ Let pat (defAux ()) $ BasicOp $ Copy v return (mem, Var $ identName v') @@ -516,20 +555,20 @@ Allocator tolore (AllocM fromlore tolore)) => [(SubExp,Diet)] -> AllocM fromlore tolore [(SubExp,Diet)] funcallArgs args = do - (valargs, mem_and_size_args) <- runWriterT $ forM args $ \(arg,d) -> do + (valargs, (ctx_args, mem_and_size_args)) <- runWriterT $ forM args $ \(arg,d) -> do t <- lift $ subExpType arg space <- lift askDefaultSpace arg' <- linearFuncallArg t space arg return (arg', d) - return $ map (,Observe) mem_and_size_args <> valargs + return $ map (,Observe) (ctx_args <> mem_and_size_args) <> valargs linearFuncallArg :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => Type -> Space -> SubExp - -> WriterT [SubExp] (AllocM fromlore tolore) SubExp + -> WriterT ([SubExp], [SubExp]) (AllocM fromlore tolore) SubExp linearFuncallArg Array{} space (Var v) = do (mem, arg') <- lift $ ensureDirectArray (Just space) v - tell [Var mem] + tell ([], [Var mem]) return arg' linearFuncallArg _ _ arg = return arg @@ -544,12 +583,12 @@ intraproceduralTransformationWithConsts onStms allocInFun where onStms stms = runAllocM handleOp hints $ allocInStms stms pure - allocInFun consts (FunDef entry fname rettype params fbody) = + allocInFun consts (FunDef entry attrs fname rettype params fbody) = runAllocM handleOp hints $ inScopeOf consts $ allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do fbody' <- insertStmsM $ allocInFunBody (map (const $ Just DefaultSpace) rettype) fbody - return $ FunDef entry fname (memoryInDeclExtType rettype) params' fbody' + return $ FunDef entry attrs fname (memoryInDeclExtType rettype) params' fbody' explicitAllocationsInStmsGeneric :: (MonadFreshNames m, HasScope tolore m, Allocable fromlore tolore) => @@ -624,9 +663,8 @@ , envConsts = stms_consts <> envConsts env } local f $ allocInStms' xs (stms'<>allocstms) - allocInStm' bnd = do - ((),stms') <- collectStms $ certifying (stmCerts bnd) $ allocInStm bnd - return stms' + allocInStm' stm = + collectStms_ $ auxing (stmAux stm) $ allocInStm stm allocInStm :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => Stm fromlore -> AllocM fromlore tolore () @@ -640,8 +678,8 @@ allocInExp :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => Exp fromlore -> AllocM fromlore tolore (Exp tolore) allocInExp (DoLoop ctx val form (Body () bodybnds bodyres)) = - allocInMergeParams mempty ctx $ \_ ctxparams' _ -> - allocInMergeParams (map paramName ctxparams') val $ + allocInMergeParams ctx $ \_ ctxparams' _ -> + allocInMergeParams val $ \new_ctx_params valparams' mk_loop_val -> do form' <- allocInLoopForm form localScope (scopeOf form') $ do @@ -690,9 +728,9 @@ fbranch'' = fbranch' { bodyResult = r_else_ext ++ drop size_ext res_else } res_if_expr = If cond tbranch'' fbranch'' $ IfDec rets'' ifsort return res_if_expr - where generalize :: (Maybe Space, Maybe MemBind) -> (Maybe Space, Maybe MemBind) + where generalize :: (Maybe Space, Maybe IxFun) -> (Maybe Space, Maybe IxFun) -> (Maybe Space, Maybe (ExtIxFun, [(PrimExp VName, PrimExp VName)])) - generalize (Just sp1, Just (ArrayIn _ ixf1)) (Just sp2, Just (ArrayIn _ ixf2)) = + generalize (Just sp1, Just ixf1) (Just sp2, Just ixf2) = if sp1 /= sp2 then (Just sp1, Nothing) else case IxFun.leastGeneralGeneralization ixf1 ixf2 of Just (ixf, m) -> (Just sp1, Just (ixf, m)) @@ -708,19 +746,12 @@ -- does not unify (e.g., does not ensures direct); implementation -- extends `allocInBodyNoDirect`, but also return `MemBind` allocInIfBody :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => - Int -> Body fromlore -> AllocM fromlore tolore (Body tolore, [Maybe MemBind]) + Int -> Body fromlore -> AllocM fromlore tolore (Body tolore, [Maybe IxFun]) allocInIfBody num_vals (Body _ bnds res) = allocInStms bnds $ \bnds' -> do let (_, val_res) = splitFromEnd num_vals res - mem_ixfs <- mapM bodyReturnMIxf val_res + mem_ixfs <- mapM subExpIxFun val_res return (Body () bnds' res, mem_ixfs) - where - bodyReturnMIxf Constant{} = return Nothing - bodyReturnMIxf (Var v) = do - info <- lookupMemInfo v - case info of - MemArray _ptp _shp _u mem_ixf -> return $ Just mem_ixf - _ -> return Nothing allocInExp e = mapExpM alloc e where alloc = identityMapper { mapOnBody = error "Unhandled Body in ExplicitAllocations" @@ -732,6 +763,18 @@ handle op } + + +subExpIxFun :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => + SubExp -> AllocM fromlore tolore (Maybe IxFun) +subExpIxFun Constant{} = return Nothing +subExpIxFun (Var v) = do + info <- lookupMemInfo v + case info of + MemArray _ptp _shp _u (ArrayIn _ ixf) -> return $ Just ixf + _ -> return Nothing + + addResCtxInIfBody :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => [ExtType] -> Body tolore -> [Maybe Space] -> [Maybe (ExtIxFun, [PrimExp VName])] -> @@ -887,10 +930,11 @@ BodyDec lore ~ (), Op lore ~ MemOp inner, Allocator lore (PatAllocM lore)) => - (inner -> Engine.SimpleM lore (Engine.OpWithWisdom inner, Stms (Engine.Wise lore))) + (Engine.OpWithWisdom inner -> UT.UsageTable) + -> (inner -> Engine.SimpleM lore (Engine.OpWithWisdom inner, Stms (Engine.Wise lore))) -> SimpleOps lore -simplifiable simplifyInnerOp = - SimpleOps mkExpDecS' mkBodyS' protectOp simplifyOp +simplifiable innerUsage simplifyInnerOp = + SimpleOps mkExpDecS' mkBodyS' protectOp opUsage simplifyOp where mkExpDecS' _ pat e = return $ Engine.mkWiseExpDec pat () e @@ -903,6 +947,13 @@ If taken tbody fbody $ IfDec [MemPrim int64] IfFallback letBind pat $ Op $ Alloc size' space protectOp _ _ _ = Nothing + + opUsage (Alloc (Var size) _) = + UT.sizeUsage size + opUsage (Alloc _ _) = + mempty + opUsage (Inner inner) = + innerUsage inner simplifyOp (Alloc size space) = (,) <$> (Alloc <$> Engine.simplify size <*> pure space) <*> pure mempty diff --git a/src/Futhark/Pass/ExplicitAllocations/Kernels.hs b/src/Futhark/Pass/ExplicitAllocations/Kernels.hs --- a/src/Futhark/Pass/ExplicitAllocations/Kernels.hs +++ b/src/Futhark/Pass/ExplicitAllocations/Kernels.hs @@ -129,19 +129,25 @@ ixfun_rearranged = IxFun.permute ixfun_base perm_inv in ixfun_rearranged -inGroupExpHints :: Exp KernelsMem -> AllocM Kernels KernelsMem [ExpHint] +semiStatic :: S.Set VName -> SubExp -> Bool +semiStatic _ Constant{} = True +semiStatic consts (Var v) = v `S.member` consts + +inGroupExpHints :: Allocator KernelsMem m => Exp KernelsMem -> m [ExpHint] inGroupExpHints (Op (Inner (SegOp (SegMap _ space ts body)))) - | any private $ kernelBodyResult body = return $ do - (t, r) <- zip ts $ kernelBodyResult body - return $ - if private r - then let seg_dims = map (primExpFromSubExp int32) $ segSpaceDims space - dims = seg_dims ++ map (primExpFromSubExp int32) (arrayDims t) - nilSlice d = DimSlice 0 d 0 - in Hint (IxFun.slice (IxFun.iota dims) $ - fullSliceNum dims $ map nilSlice seg_dims) $ - ScalarSpace (arrayDims t) $ elemType t - else NoHint + | any private $ kernelBodyResult body = do + consts <- askConsts + return $ do + (t, r) <- zip ts $ kernelBodyResult body + return $ + if private r && all (semiStatic consts) (arrayDims t) + then let seg_dims = map (primExpFromSubExp int32) $ segSpaceDims space + dims = seg_dims ++ map (primExpFromSubExp int32) (arrayDims t) + nilSlice d = DimSlice 0 d 0 + in Hint (IxFun.slice (IxFun.iota dims) $ + fullSliceNum dims $ map nilSlice seg_dims) $ + ScalarSpace (arrayDims t) $ elemType t + else NoHint where private (Returns ResultPrivate _) = True private _ = False inGroupExpHints e = return $ replicate (expExtTypeSize e) NoHint @@ -158,9 +164,6 @@ return $ Hint ixfun $ ScalarSpace (shapeDims shape) pt | otherwise = return NoHint - - semiStatic _ Constant{} = True - semiStatic consts (Var v) = v `S.member` consts -- | The pass from 'Kernels' to 'KernelsMem'. explicitAllocations :: Pass Kernels KernelsMem diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -230,10 +230,10 @@ transformFunDef :: (MonadFreshNames m, MonadLogger m) => Scope Out.Kernels -> FunDef SOACS -> m (Out.FunDef Out.Kernels) -transformFunDef scope (FunDef entry name rettype params body) = runDistribM $ do +transformFunDef scope (FunDef entry attrs name rettype params body) = runDistribM $ do body' <- localScope (scope <> scopeOfFParams params) $ transformBody mempty body - return $ FunDef entry name rettype params body' + return $ FunDef entry attrs name rettype params body' type KernelsStms = Stms Out.Kernels @@ -393,13 +393,13 @@ lvl <- segThreadCapped [w] "segscan" $ NoRecommendation SegNoVirt addStms =<< segScan lvl res_pat w scan_ops map_lam' arrs [] [] -transformStm path (Let res_pat (StmAux cs _ _) (Op (Screma w form arrs))) +transformStm path (Let res_pat aux (Op (Screma w form arrs))) | Just [Reduce comm red_fun nes] <- isReduceSOAC form, let comm' | commutativeLambda red_fun = Commutative | otherwise = comm, Just do_irwim <- irwim res_pat w comm' red_fun $ zip nes arrs = do types <- asksScope scopeForSOACs - (_, bnds) <- fst <$> runBinderT (simplifyStms =<< collectStms_ (certifying cs do_irwim)) types + (_, bnds) <- fst <$> runBinderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types transformStms path $ stmsToList bnds transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w form arrs))) @@ -436,7 +436,7 @@ if not (lambdaContainsParallelism map_lam) || "sequential_inner" `inAttrs` stmAuxAttrs aux then paralleliseOuter - else if incrementalFlattening then do + else do ((outer_suff, outer_suff_key), suff_stms) <- sufficientParallelism "suff_outer_redomap" [w] path @@ -444,7 +444,6 @@ inner_stms <- innerParallelBody ((outer_suff_key, False):path) (suff_stms<>) <$> kernelAlternatives pat inner_stms [(outer_suff, outer_stms)] - else paralleliseOuter -- Streams can be handled in two different ways - either we -- sequentialise the body or we keep it parallel and distribute. @@ -457,8 +456,9 @@ (stmsToList . snd <$> runBinderT (certifying cs $ sequentialStreamWholeArray pat w [] map_fun arrs) types) transformStm path (Let pat aux@(StmAux cs _ _) (Op (Stream w (Parallel o comm red_fun nes) fold_fun arrs))) - | incrementalFlattening, - not ("sequential_inner" `inAttrs` stmAuxAttrs aux) = do + | "sequential_inner" `inAttrs` stmAuxAttrs aux = + paralleliseOuter path + | otherwise = do ((outer_suff, outer_suff_key), suff_stms) <- sufficientParallelism "suff_outer_stream" [w] path @@ -468,8 +468,6 @@ (suff_stms<>) <$> kernelAlternatives pat inner_stms [(outer_suff, outer_stms)] - | otherwise = paralleliseOuter path - where paralleliseOuter path' | not $ all primType $ lambdaReturnType red_fun = do @@ -490,7 +488,7 @@ (stms<>) <$> inScopeOf stms - (transformStm path' $ Let red_pat aux $ + (transformStm path' $ Let red_pat aux { stmAuxAttrs = mempty } $ Op (Screma num_threads reduce_soac red_results)) | otherwise = do @@ -566,48 +564,73 @@ -> DistribM ((SubExp, Name), Out.Stms Out.Kernels) sufficientParallelism desc ws path = cmpSizeLe desc (Out.SizeThreshold path) ws --- | Returns the sizes of nested parallelism. -nestedParallelism :: Body -> [SubExp] -nestedParallelism = concatMap (parallelism . stmExp) . bodyStms - where parallelism (Op (Scatter w _ _ _)) = [w] - parallelism (Op (Screma w _ _)) = [w] - parallelism (Op (Hist w _ _ _)) = [w] - parallelism (Op (Stream w Sequential{} lam _)) - | chunk_size_param : _ <- lambdaParams lam = - let update (Var v) | v == paramName chunk_size_param = w - update se = se - in map update $ nestedParallelism $ lambdaBody lam - parallelism (DoLoop _ _ _ body) = nestedParallelism body - parallelism _ = [] - --- | Intra-group parallelism is worthwhile if the lambda contains --- non-map nested parallelism, or any nested parallelism inside a --- loop. +-- | Intra-group parallelism is worthwhile if the lambda contains more +-- than one instance of non-map nested parallelism, or any nested +-- parallelism inside a loop. worthIntraGroup :: Lambda -> Bool -worthIntraGroup lam = interesting $ lambdaBody lam - where interesting body = not (null $ nestedParallelism body) && - not (onlyMaps $ bodyStms body) - onlyMaps = all $ isMapOrSeq . stmExp - isMapOrSeq (Op (Screma _ form@(ScremaForm _ _ lam') _)) - | isJust $ isMapSOAC form = not $ worthIntraGroup lam' - isMapOrSeq (Op Scatter{}) = True -- Basically a map. - isMapOrSeq (DoLoop _ _ _ body) = - null $ nestedParallelism body - isMapOrSeq (Op _) = False - isMapOrSeq _ = True +worthIntraGroup lam = bodyInterest (lambdaBody lam) > 1 + where bodyInterest body = + sum $ interest <$> bodyStms body + interest stm + | "sequential" `inAttrs` attrs = + 0::Int + | Op (Screma w form _) <- stmExp stm, + Just lam' <- isMapSOAC form = + mapLike w lam' + | Op (Scatter w lam' _ _) <- stmExp stm = + mapLike w lam' + | DoLoop _ _ _ body <- stmExp stm = + bodyInterest body * 10 + | Op (Screma w (ScremaForm _ _ lam') _) <- stmExp stm = + zeroIfTooSmall w + bodyInterest (lambdaBody lam') + | Op (Stream _ (Sequential _) lam' _) <- stmExp stm = + bodyInterest $ lambdaBody lam' + | otherwise = + 0 --- | A lambda is worth sequentialising if it contains nested + where attrs = stmAuxAttrs $ stmAux stm + sequential_inner = "sequential_inner" `inAttrs` attrs + + zeroIfTooSmall (Constant (IntValue x)) + | intToInt64 x < 32 = 0 + zeroIfTooSmall _ = 1 + + mapLike w lam' = + if sequential_inner + then 0 + else max (zeroIfTooSmall w) (bodyInterest (lambdaBody lam')) + +-- | A lambda is worth sequentialising if it contains enough nested -- parallelism of an interesting kind. worthSequentialising :: Lambda -> Bool -worthSequentialising lam = interesting $ lambdaBody lam - where interesting body = any (interesting' . stmExp) $ bodyStms body - interesting' (Op (Screma _ form@(ScremaForm _ _ lam') _)) - | isJust $ isMapSOAC form = worthSequentialising lam' - interesting' (Op Scatter{}) = False -- Basically a map. - interesting' (DoLoop _ _ _ body) = interesting body - interesting' (Op _) = True - interesting' _ = False +worthSequentialising lam = bodyInterest (lambdaBody lam) > 1 + where bodyInterest body = + sum $ interest <$> bodyStms body + interest stm + | "sequential" `inAttrs` attrs = + 0::Int + | Op (Screma _ form@(ScremaForm _ _ lam') _) <- stmExp stm, + isJust $ isMapSOAC form = + if sequential_inner + then 0 + else bodyInterest (lambdaBody lam') + | Op Scatter{} <- stmExp stm = + 0 -- Basically a map. + | DoLoop _ _ _ body <- stmExp stm = + bodyInterest body * 10 + | Op (Screma _ form@(ScremaForm _ _ lam') _) <- stmExp stm = + 1 + bodyInterest (lambdaBody lam') + + -- Give this a bigger score if it's a redomap, as these + -- are often tileable and thus benefit more from + -- sequentialisation. + case isRedomapSOAC form of + Just _ -> 1 + Nothing -> 0 + | otherwise = + 0 + where attrs = stmAuxAttrs $ stmAux stm + sequential_inner = "sequential_inner" `inAttrs` attrs onTopLevelStms :: KernelPath -> Stms SOACS -> DistNestT Out.Kernels DistribM KernelsStms @@ -634,32 +657,31 @@ runDistNestT (env path') $ distributeMapBodyStms acc (bodyStms $ lambdaBody lam) - if not incrementalFlattening && - not ("sequential_inner" `inAttrs` stmAuxAttrs aux) - then exploitInnerParallelism path - else do + let exploitOuterParallelism path' = do + let lam' = soacsLambdaToKernels lam + runDistNestT (env path') $ distribute $ + addStmsToAcc (bodyStms $ lambdaBody lam') acc - let exploitOuterParallelism path' = do - let lam' = soacsLambdaToKernels lam - runDistNestT (env path') $ distribute $ - addStmsToAcc (bodyStms $ lambdaBody lam') acc + onMap' (newKernel loopnest) path exploitOuterParallelism exploitInnerParallelism pat lam + where acc = DistAcc { distTargets = singleTarget (pat, bodyResult $ lambdaBody lam) + , distStms = mempty + } - onMap' (newKernel loopnest) path exploitOuterParallelism exploitInnerParallelism pat lam - where acc = DistAcc { distTargets = singleTarget (pat, bodyResult $ lambdaBody lam) - , distStms = mempty - } +onlyExploitIntra :: Attrs -> Bool +onlyExploitIntra attrs = + AttrComp "incremental_flattening" ["only_intra"] `inAttrs` attrs mayExploitOuter :: Attrs -> Bool mayExploitOuter attrs = not $ - "incremental_flattening_no_outer" `inAttrs` attrs || - "incremental_flattening_only_inner" `inAttrs` attrs + AttrComp "incremental_flattening" ["no_outer"] `inAttrs` attrs || + AttrComp "incremental_flattening" ["only_inner"] `inAttrs` attrs mayExploitIntra :: Attrs -> Bool mayExploitIntra attrs = not $ - "incremental_flattening_no_intra" `inAttrs` attrs || - "incremental_flattening_only_inner" `inAttrs` attrs + AttrComp "incremental_flattening" ["no_intra"] `inAttrs` attrs || + AttrComp "incremental_flattening" ["only_inner"] `inAttrs` attrs onMap' :: KernelNest -> KernelPath -> (KernelPath -> DistribM (Out.Stms Out.Kernels)) @@ -671,26 +693,27 @@ let nest_ws = kernelNestWidths loopnest res = map Var $ patternNames pat aux = loopNestingAux $ innermostKernelNesting loopnest + attrs = stmAuxAttrs aux types <- askScope ((outer_suff, outer_suff_key), outer_suff_stms) <- sufficientParallelism "suff_outer_par" nest_ws path - intra <- if worthIntraGroup lam && mayExploitIntra (stmAuxAttrs aux) then + intra <- if onlyExploitIntra (stmAuxAttrs aux) || + (worthIntraGroup lam && mayExploitIntra attrs) then flip runReaderT types $ intraGroupParallelise loopnest lam else return Nothing seq_body <- renameBody =<< mkBody <$> mk_seq_stms ((outer_suff_key, True) : path) <*> pure res let seq_alts = [(outer_suff, seq_body) - | worthSequentialising lam, - mayExploitOuter $ stmAuxAttrs aux] + | worthSequentialising lam, mayExploitOuter attrs] case intra of Nothing -> do par_body <- renameBody =<< mkBody <$> mk_par_stms ((outer_suff_key, False) : path) <*> pure res - if "sequential_inner" `inAttrs` stmAuxAttrs aux + if "sequential_inner" `inAttrs` attrs then kernelAlternatives pat seq_body [] else (outer_suff_stms<>) <$> kernelAlternatives pat par_body seq_alts @@ -700,7 +723,7 @@ ((intra_ok, intra_suff_key), intra_suff_stms) <- do ((intra_suff, suff_key), check_suff_stms) <- - sufficientParallelism "suff_intra_par" [intra_avail_par] $ + sufficientParallelism "suff_intra_par" (nest_ws ++ [intra_avail_par]) $ (outer_suff_key, False) : path runBinder $ do @@ -724,8 +747,11 @@ (intra_suff_key, False)] ++ path) <*> pure res - if "sequential_inner" `inAttrs` stmAuxAttrs aux + if "sequential_inner" `inAttrs` attrs then kernelAlternatives pat seq_body [] + else + if onlyExploitIntra attrs + then (intra_suff_stms<>) <$> kernelAlternatives pat group_par_body [] else ((outer_suff_stms<>intra_suff_stms)<>) <$> kernelAlternatives pat par_body (seq_alts ++ [(intra_ok, group_par_body)]) @@ -734,8 +760,6 @@ onInnerMap path maploop@(MapLoop pat aux w lam arrs) acc | unbalancedLambda lam, lambdaContainsParallelism lam = addStmToAcc (mapLoopStm maploop) acc - | not incrementalFlattening, not $ "sequential_inner" `inAttrs` stmAuxAttrs aux = - distributeMap maploop acc | otherwise = distributeSingleStm acc (mapLoopStm maploop) >>= \case Just (post_kernels, res, nest, acc') 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 @@ -14,7 +14,6 @@ , bodyContainsParallelism , lambdaContainsParallelism , determineReduceOp - , incrementalFlattening , histKernel , DistEnv (..) @@ -49,7 +48,7 @@ import qualified Futhark.IR.SOACS as SOACS import Futhark.IR.SOACS.SOAC hiding (HistOp, histDest) import Futhark.IR.SOACS (SOACS) -import Futhark.IR.SOACS.Simplify (simpleSOACS) +import Futhark.IR.SOACS.Simplify (simpleSOACS, simplifyStms) import Futhark.IR.SegOp import Futhark.MonadFreshNames import Futhark.Tools @@ -195,17 +194,71 @@ } where provided = namesFromList $ patternNames $ stmPattern stm -mapNesting :: (Monad m, DistLore lore) => +leavingNesting :: (MonadFreshNames m, DistLore lore) => + DistAcc lore -> DistNestT lore m (DistAcc lore) + +leavingNesting acc = + case popInnerTarget $ distTargets acc of + Nothing -> + error "The kernel targets list is unexpectedly small" + + Just ((pat, res), newtargets) + | not $ null $ distStms acc -> do + -- Any statements left over correspond to something that + -- could not be distributed because it would cause irregular + -- arrays. These must be reconstructed into a a Map SOAC + -- that will be sequentialised. XXX: life would be better if + -- we were able to distribute irregular parallelism. + (Nesting _ inner, _) <- asks distNest + let MapNesting _ aux w params_and_arrs = inner + body = Body () (distStms acc) res + used_in_body = freeIn body + (used_params, used_arrs) = + unzip $ + filter ((`nameIn` used_in_body) . paramName . fst) params_and_arrs + lam' = Lambda { lambdaParams = used_params + , lambdaBody = body + , lambdaReturnType = map rowType $ patternTypes pat + } + stms <- runBinder_ $ auxing aux $ FOT.transformSOAC pat $ + Screma w (mapSOAC lam') used_arrs + + return $ acc { distTargets = newtargets, distStms = stms } + + | otherwise -> do + -- Any results left over correspond to a Replicate or a Copy in + -- the parent nesting, depending on whether the argument is a + -- parameter of the innermost nesting. + (Nesting _ inner_nesting, _) <- asks distNest + let w = loopNestingWidth inner_nesting + aux = loopNestingAux inner_nesting + inps = loopNestingParamsAndArrs inner_nesting + + remnantStm pe (Var v) + | Just (_, arr) <- find ((==v) . paramName . fst) inps = + Let (Pattern [] [pe]) aux $ + BasicOp $ Copy arr + remnantStm pe se = + Let (Pattern [] [pe]) aux $ + BasicOp $ Replicate (Shape [w]) se + + stms = + stmsFromList $ zipWith remnantStm (patternElements pat) res + + return $ acc { distTargets = newtargets, distStms = stms } + +mapNesting :: (MonadFreshNames m, DistLore lore) => PatternT Type -> StmAux () -> SubExp -> Lambda SOACS -> [VName] - -> DistNestT lore m a - -> DistNestT lore m a -mapNesting pat aux w lam arrs = local $ \env -> - env { distNest = pushInnerNesting nest $ distNest env - , distScope = castScope (scopeOf lam) <> distScope env - } + -> DistNestT lore m (DistAcc lore) + -> DistNestT lore m (DistAcc lore) +mapNesting pat aux w lam arrs m = + local extend $ leavingNesting =<< m where nest = Nesting mempty $ MapNesting pat aux w $ zip (lambdaParams lam) arrs + extend env = env { distNest = pushInnerNesting nest $ distNest env + , distScope = castScope (scopeOf lam) <> distScope env + } inNesting :: (Monad m, DistLore lore) => KernelNest -> DistNestT lore m a -> DistNestT lore m a @@ -220,27 +273,16 @@ asNesting = Nesting mempty bodyContainsParallelism :: Body SOACS -> Bool -bodyContainsParallelism = any (isMap . stmExp) . bodyStms - where isMap Op{} = True +bodyContainsParallelism = any isParallelStm . bodyStms + where isParallelStm stm = + isMap (stmExp stm) && + not ("sequential" `inAttrs` stmAuxAttrs (stmAux stm)) + isMap Op{} = True isMap _ = False lambdaContainsParallelism :: Lambda SOACS -> Bool lambdaContainsParallelism = bodyContainsParallelism . lambdaBody --- Enable if you want the cool new versioned code. Beware: may be --- slower in practice. Caveat emptor (and you are the emptor). -incrementalFlattening :: Bool -incrementalFlattening = isJust $ lookup "FUTHARK_INCREMENTAL_FLATTENING" unixEnvironment - -leavingNesting :: MonadFreshNames m => - DistAcc lore -> DistNestT lore m (DistAcc lore) -leavingNesting acc = - case popInnerTarget $ distTargets acc of - Nothing -> - error "The kernel targets list is unexpectedly small" - Just (_, newtargets) -> - return acc { distTargets = newtargets } - distributeMapBodyStms :: (MonadFreshNames m, DistLore lore) => DistAcc lore -> Stms SOACS -> DistNestT lore m (DistAcc lore) distributeMapBodyStms orig_acc = distribute <=< onStms orig_acc . stmsToList where @@ -304,9 +346,14 @@ nest' <- expandKernelNest pat_unused nest types <- asksScope scopeForSOACs - bnds <- runReaderT - (interchangeLoops nest' (SeqLoop perm pat val form body)) types - onTopLevelStms bnds + -- Simplification is key to hoisting out statements that + -- were variant to the loop, but invariant to the outer maps + -- (which are now innermost). + stms <- + (`runReaderT` types) $ + fmap snd . simplifyStms =<< + interchangeLoops nest' (SeqLoop perm pat val form body) + onTopLevelStms stms return acc' _ -> addStmToAcc bnd acc @@ -327,7 +374,10 @@ addPostStms kernels types <- asksScope scopeForSOACs let branch = Branch perm pat cond tbranch fbranch ret - stms <- runReaderT (interchangeBranch nest' branch) types + stms <- + (`runReaderT` types) $ + fmap snd . simplifyStms =<< + interchangeBranch nest' branch onTopLevelStms stms return acc' _ -> @@ -368,6 +418,23 @@ _ -> addStmToAcc bnd acc +-- Parallelise Index slices if the result is going to be returned +-- directly from the kernel. This is because we would otherwise have +-- to sequentialise writing the result, which may be costly. +maybeDistributeStm stm@(Let (Pattern [] [pe]) + aux + (BasicOp (Index arr slice))) acc + | not $ null $ sliceDims slice, + Var (patElemName pe) `elem` snd (innerTarget (distTargets acc)) = + distributeSingleStm acc stm >>= \case + Just (kernels, _res, nest, acc') -> + localScope (typeEnvFromDistAcc acc') $ do + addPostStms kernels + postStm =<< segmentedGatherKernel nest (stmAuxCerts aux) arr slice + return acc' + _ -> + addStmToAcc stm acc + -- If the scan can be distributed by itself, we will turn it into a -- segmented scan. -- @@ -398,8 +465,7 @@ -- sequentialised in the default case for this function. maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc | Just (reds, map_lam) <- isRedomapSOAC form, - Reduce comm lam nes <- singleReduce reds, - isIdentityLambda map_lam || incrementalFlattening = + Reduce comm lam nes <- singleReduce reds = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> @@ -419,9 +485,8 @@ _ -> addStmToAcc bnd acc -maybeDistributeStm (Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc - | incrementalFlattening || isNothing (isRedomapSOAC form) = do - -- This with-loop is too complicated for us to immediately do +maybeDistributeStm (Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc = do + -- This Screma is too complicated for us to immediately do -- anything, so split it up and try again. scope <- asksScope scopeForSOACs distributeMapBodyStms acc . fmap (certify cs) . snd =<< @@ -429,9 +494,6 @@ maybeDistributeStm (Let pat aux (BasicOp (Replicate (Shape (d:ds)) v))) acc | [t] <- patternTypes pat = do - -- XXX: We need a temporary dummy binding to prevent an empty - -- map body. The kernel extractor does not like empty map - -- bodies. tmp <- newVName "tmp" let rowt = rowType t newbnd = Let pat aux $ Op $ Screma d (mapSOAC lam) [] @@ -526,8 +588,8 @@ addStmToAcc stm acc where segmentedConcat nest = - isSegmentedOp nest [0] w mempty mempty [] (x:xs) $ - \pat _ _ _ (x':xs') _ -> + isSegmentedOp nest [0] mempty mempty [] (x:xs) $ + \pat _ _ _ (x':xs') -> let d' = d + length (snd nest) + 1 in addStm $ Let pat aux $ BasicOp $ Concat d' x' xs' w @@ -542,44 +604,25 @@ distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | res == map Var (patternNames $ stmPattern bnd), - (outer, inners) <- nest, + (outer, _) <- nest, [(arr_p, arr)] <- loopNestingParamsAndArrs outer, boundInKernelNest nest `namesIntersection` freeIn bnd - == oneName (paramName arr_p) -> do + == oneName (paramName arr_p), + perfectlyMapped arr nest -> do addPostStms kernels let outerpat = loopNestingPattern $ fst nest localScope (typeEnvFromDistAcc acc') $ do - (arr', pre_stms) <- repeatMissing arr (outer:inners) - f_stms <- inScopeOf pre_stms $ f nest outerpat arr' - postStm $ pre_stms <> f_stms + postStm =<< f nest outerpat arr return acc' _ -> addStmToAcc bnd acc - where -- | For an imperfectly mapped array, repeat the missing - -- dimensions to make it look like it was in fact perfectly - -- mapped. - repeatMissing arr inners = do - arr_t <- lookupType arr - let shapes = determineRepeats arr arr_t inners - if all (==Shape []) shapes then return (arr, mempty) - else do - let (outer_shapes, inner_shape) = repeatShapes shapes arr_t - arr_t' = repeatDims outer_shapes inner_shape arr_t - arr' <- newVName $ baseString arr - return (arr', oneStm $ Let (Pattern [] [PatElem arr' arr_t']) (defAux ()) $ - BasicOp $ Repeat outer_shapes inner_shape arr) - determineRepeats arr arr_t nests - | (skipped, arr_nest:nests') <- break (hasInput arr) nests, - [(arr_p, _)] <- loopNestingParamsAndArrs arr_nest = - Shape (map loopNestingWidth skipped) : - determineRepeats (paramName arr_p) (rowType arr_t) nests' + where perfectlyMapped arr (outer, nest) + | [(p, arr')] <- loopNestingParamsAndArrs outer, + arr == arr' = + case nest of [] -> True + x:xs -> perfectlyMapped (paramName p) (x, xs) | otherwise = - Shape (map loopNestingWidth nests) : replicate (arrayRank arr_t) (Shape []) - - hasInput arr nest - | [(_, arr')] <- loopNestingParamsAndArrs nest, arr' == arr = True - | otherwise = False - + False distribute :: (MonadFreshNames m, DistLore lore) => DistAcc lore -> DistNestT lore m (DistAcc lore) distribute acc = @@ -738,6 +781,39 @@ letBind pat $ Op $ segOp k +segmentedGatherKernel :: (MonadFreshNames m, DistLore lore) => + KernelNest + -> Certificates + -> VName + -> Slice SubExp + -> DistNestT lore m (Stms lore) +segmentedGatherKernel nest cs arr slice = do + let slice_dims = sliceDims slice + slice_gtids <- replicateM (length slice_dims) (newVName "gtid_slice") + + (base_ispace, kernel_inps) <- flatKernel nest + let ispace = base_ispace ++ zip slice_gtids slice_dims + + ((res_t, res), kstms) <- runBinder $ do + -- Compute indexes into full array. + slice'' <- subExpSlice $ + sliceSlice (primExpSlice slice) $ + primExpSlice $ map (DimFix . Var) slice_gtids + v' <- certifying cs $ letSubExp "v" $ BasicOp $ Index arr slice'' + v_t <- subExpType v' + return (v_t, Returns ResultMaySimplify v') + + mk_lvl <- mkSegLevel + (k, prestms) <- mapKernel mk_lvl ispace kernel_inps [res_t] $ + KernelBody () kstms [res] + + traverse renameStm <=< runBinder_ $ do + addStms prestms + + let pat = Pattern [] $ patternValueElements $ loopNestingPattern $ fst nest + + letBind pat $ Op $ segOp k + segmentedHistKernel :: (MonadFreshNames m, DistLore lore) => KernelNest -> [Int] @@ -838,8 +914,8 @@ -> DistNestT lore m (Maybe (Stms lore)) segmentedScanomapKernel nest perm segment_size lam map_lam nes arrs = do mk_lvl <- asks distSegLevel - isSegmentedOp nest perm segment_size (freeIn lam) (freeIn map_lam) nes arrs $ - \pat ispace inps nes' _ _ -> do + isSegmentedOp nest perm (freeIn lam) (freeIn map_lam) nes [] $ + \pat ispace inps nes' _ -> do let scan_op = SegBinOp Noncommutative lam nes' mempty lvl <- mk_lvl (segment_size : map snd ispace) "segscan" $ NoRecommendation SegNoVirt addStms =<< traverse renameStm =<< @@ -854,8 +930,8 @@ -> DistNestT lore m (Maybe (Stms lore)) regularSegmentedRedomapKernel nest perm segment_size comm lam map_lam nes arrs = do mk_lvl <- asks distSegLevel - isSegmentedOp nest perm segment_size (freeIn lam) (freeIn map_lam) nes arrs $ - \pat ispace inps nes' _ _ -> do + isSegmentedOp nest perm (freeIn lam) (freeIn map_lam) nes [] $ + \pat ispace inps nes' _ -> do let red_op = SegBinOp comm lam nes' mempty lvl <- mk_lvl (segment_size : map snd ispace) "segred" $ NoRecommendation SegNoVirt addStms =<< traverse renameStm =<< @@ -864,16 +940,15 @@ isSegmentedOp :: (MonadFreshNames m, DistLore lore) => KernelNest -> [Int] - -> SubExp -> Names -> Names -> [SubExp] -> [VName] -> (PatternT Type -> [(VName, SubExp)] -> [KernelInput] - -> [SubExp] -> [VName] -> [VName] + -> [SubExp] -> [VName] -> BinderT lore m ()) -> DistNestT lore m (Maybe (Stms lore)) -isSegmentedOp nest perm segment_size free_in_op _free_in_fold_op nes arrs m = runMaybeT $ do +isSegmentedOp nest perm free_in_op _free_in_fold_op nes arrs m = runMaybeT $ do -- We must verify that array inputs to the operation are inputs to -- the outermost loop nesting or free in the loop nest. Nothing -- free in the op may be bound by the nest. Furthermore, the @@ -900,8 +975,6 @@ Just inp | kernelInputIndices inp == map Var indices -> return $ return $ kernelInputArray inp - | not (kernelInputArray inp `nameIn` bound_by_nest) -> - return $ replicateMissing ispace inp Nothing | not (arr `nameIn` bound_by_nest) -> -- This input is something that is free inside -- the loop nesting. We will have to replicate @@ -910,7 +983,7 @@ letExp (baseString arr ++ "_repd") (BasicOp $ Replicate (Shape $ map snd ispace) $ Var arr) _ -> - fail "Input not free or outermost." + fail "Input not free, perfectly mapped, or outermost." nes' <- mapM prepareNe nes @@ -918,42 +991,12 @@ scope <- lift askScope lift $ lift $ flip runBinderT_ scope $ do - -- We must make sure all inputs are of size - -- segment_size*nesting_size. - total_num_elements <- - letSubExp "total_num_elements" =<< - foldBinOp (Mul Int32 OverflowUndef) segment_size (map snd ispace) - - let flatten arr = do - arr_shape <- arrayShape <$> lookupType arr - -- CHECKME: is the length the right thing here? We want to - -- reproduce the parameter type. - let reshape = reshapeOuter [DimNew total_num_elements] - (2+length (snd nest)) arr_shape - letExp (baseString arr ++ "_flat") $ - BasicOp $ Reshape reshape arr - nested_arrs <- sequence mk_arrs - arrs' <- mapM flatten nested_arrs let pat = Pattern [] $ rearrangeShape perm $ patternValueElements $ loopNestingPattern $ fst nest - m pat ispace kernel_inps nes' nested_arrs arrs' - - where replicateMissing ispace inp = do - t <- lookupType $ kernelInputArray inp - let inp_is = kernelInputIndices inp - shapes = determineRepeats ispace inp_is - (outer_shapes, inner_shape) = repeatShapes shapes t - letExp "repeated" $ BasicOp $ - Repeat outer_shapes inner_shape $ kernelInputArray inp - - determineRepeats ispace (i:is) - | (skipped_ispace, ispace') <- span ((/=i) . Var . fst) ispace = - Shape (map snd skipped_ispace) : determineRepeats (drop 1 ispace') is - determineRepeats ispace _ = - [Shape $ map snd ispace] + m pat ispace kernel_inps nes' nested_arrs permutationAndMissing :: PatternT Type -> [SubExp] -> Maybe ([Int], [PatElemT Type]) permutationAndMissing pat res = do @@ -1003,7 +1046,6 @@ -> DistNestT lore m (DistAcc lore) distributeMap (MapLoop pat aux w lam arrs) acc = distribute =<< - leavingNesting =<< mapNesting pat aux w lam arrs (distribute =<< distributeMapBodyStms acc' lam_bnds) diff --git a/src/Futhark/Pass/ExtractKernels/Interchange.hs b/src/Futhark/Pass/ExtractKernels/Interchange.hs --- a/src/Futhark/Pass/ExtractKernels/Interchange.hs +++ b/src/Futhark/Pass/ExtractKernels/Interchange.hs @@ -16,7 +16,6 @@ import Control.Monad.RWS.Strict import Data.Maybe -import qualified Data.Map as M import Data.List (find) import Futhark.Pass.ExtractKernels.Distribution @@ -61,9 +60,7 @@ runBinder $ localScope (scopeOfLParams new_params) $ unzip . catMaybes <$> mapM copyOrRemoveParam params_and_arrs - body' <- mkDummyStms (params'<>new_params) body - - let lam = Lambda (params'<>new_params) body' rettype + let lam = Lambda (params'<>new_params) body rettype map_bnd = Let loop_pat_expanded aux $ Op $ Screma w (mapSOAC lam) $ arrs' <> new_arrs res = map Var $ patternNames loop_pat_expanded @@ -99,22 +96,6 @@ expandPatElem (PatElem name t) = PatElem name $ arrayOfRow t w - -- | The kernel extractor cannot handle identity mappings, so - -- insert dummy statements for body results that are just a - -- lambda parameter. - mkDummyStms params (Body _ stms res) = do - (res', extra_stms) <- unzip <$> mapM dummyStm res - return $ Body () (stms<>mconcat extra_stms) res' - where dummyStm (Var v) - | Just p <- find ((==v) . paramName) params = do - dummy <- newVName (baseString v ++ "_dummy") - return (Var dummy, - oneStm $ - Let (Pattern [] [PatElem dummy $ paramType p]) - (defAux ()) $ - BasicOp $ SubExp $ Var $ paramName p) - dummyStm se = return (se, mempty) - -- | Given a (parallel) map nesting and an inner sequential loop, move -- the maps inside the sequential loop. The result is several -- statements - one of these will be the loop, which will then contain @@ -137,7 +118,7 @@ branchStm (Branch _ pat cond tbranch fbranch ret) = Let pat (defAux ()) $ If cond tbranch fbranch ret -interchangeBranch1 :: (MonadBinder m, LocalScope SOACS m) => +interchangeBranch1 :: (MonadBinder m) => Branch -> LoopNesting -> m Branch interchangeBranch1 (Branch perm branch_pat cond tbranch fbranch (IfDec ret if_sort)) @@ -146,20 +127,13 @@ pat' = Pattern [] $ rearrangeShape perm $ patternValueElements pat (params, arrs) = unzip params_and_arrs - lam_ret = map rowType $ patternTypes pat + lam_ret = rearrangeShape perm $ map rowType $ patternTypes pat branch_pat' = Pattern [] $ map (fmap (`arrayOfRow` w)) $ patternElements branch_pat mkBranch branch = (renameBody=<<) $ do - let bound_in_branch = scopeOf (bodyStms branch) - branch' <- - -- XXX: We may need dummys binding to prevent identity - -- mappings. The kernel extractor does not like identity - -- mappings. - runBodyBinder $ - resultBody <$> (mapM (dummyBindIfNotIn bound_in_branch) =<< bodyBind branch) - let lam = Lambda params branch' lam_ret + let lam = Lambda params branch lam_ret res = map Var $ patternNames branch_pat' map_bnd = Let branch_pat' aux $ Op $ Screma w (mapSOAC lam) arrs return $ mkBody (oneStm map_bnd) res @@ -168,15 +142,6 @@ fbranch' <- mkBranch fbranch return $ Branch [0..patternSize pat-1] pat' cond tbranch' fbranch' $ IfDec ret' if_sort - where dummyBind se = do - dummy <- newVName "dummy" - letBindNames [dummy] (BasicOp $ SubExp se) - return $ Var dummy - - dummyBindIfNotIn bound_in_branch se - | Var v <- se, - v `M.member` bound_in_branch = return se - | otherwise = dummyBind se interchangeBranch :: (MonadFreshNames m, HasScope SOACS m) => KernelNest -> Branch -> m (Stms SOACS) diff --git a/src/Futhark/Pass/ExtractKernels/Intragroup.hs b/src/Futhark/Pass/ExtractKernels/Intragroup.hs --- a/src/Futhark/Pass/ExtractKernels/Intragroup.hs +++ b/src/Futhark/Pass/ExtractKernels/Intragroup.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} -- | Extract limited nested parallelism for execution inside -- individual kernel workgroups. module Futhark.Pass.ExtractKernels.Intragroup @@ -25,6 +26,7 @@ import Futhark.Pass.ExtractKernels.Distribution import Futhark.Pass.ExtractKernels.BlockedKernel import Futhark.Pass.ExtractKernels.ToKernels +import qualified Futhark.Transform.FirstOrderTransform as FOT import Futhark.Util (chunks) import Futhark.Util.Log @@ -166,6 +168,11 @@ fbody' <- intraGroupBody lvl fbody certifying (stmAuxCerts aux) $ letBind pat $ If cond tbody' fbody' ifdec + + Op soac + | "sequential_outer" `inAttrs` stmAuxAttrs aux -> + mapM_ (intraGroupStm lvl) . fmap (certify (stmAuxCerts aux)) =<< + runBinder_ (FOT.transformSOAC pat soac) Op (Screma w form arrs) | Just lam <- isMapSOAC form -> do diff --git a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs --- a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs @@ -50,7 +50,7 @@ per_thread_elements <- letSubExp "per_thread_elements" =<< - eDivRoundingUp Int64 (eSubExp w64) (toExp =<< asIntS Int64 num_threads) + eBinOp (SDivUp Int64 Unsafe) (eSubExp w64) (toExp =<< asIntS Int64 num_threads) return $ KernelSize per_thread_elements num_threads @@ -243,7 +243,7 @@ usable_groups <- letSubExp "segmap_usable_groups" . BasicOp . ConvOp (SExt Int64 Int32) =<< letSubExp "segmap_usable_groups_64" =<< - eDivRoundingUp Int64 (eSubExp w64) + eBinOp (SDivUp Int64 Unsafe) (eSubExp w64) (eSubExp =<< asIntS Int64 group_size) return $ SegThread (Count usable_groups) (Count group_size) SegNoVirt NoRecommendation v -> do diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs --- a/src/Futhark/Pass/KernelBabysitting.hs +++ b/src/Futhark/Pass/KernelBabysitting.hs @@ -386,7 +386,8 @@ (w_padded, padding) <- paddedScanReduceInput w num_chunks' - per_chunk <- letSubExp "per_chunk" $ BasicOp $ BinOp (SQuot Int32) w_padded num_chunks' + per_chunk <- letSubExp "per_chunk" $ + BasicOp $ BinOp (SQuot Int32 Unsafe) w_padded num_chunks' arr_t <- lookupType arr arr_padded <- padArray w_padded padding arr_t rearrange num_chunks' w_padded per_chunk (baseString arr) arr_padded arr_t diff --git a/src/Futhark/Pass/ResolveAssertions.hs b/src/Futhark/Pass/ResolveAssertions.hs deleted file mode 100644 --- a/src/Futhark/Pass/ResolveAssertions.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | Go through the program and use algebraic simplification and range --- analysis to try to figure out which assertions are statically true. --- --- Currently implemented by running the simplifier with a special rule --- that is too expensive to run all the time. - -module Futhark.Pass.ResolveAssertions - ( resolveAssertions - ) - where - -import Data.Maybe -import Data.Monoid - -import qualified Futhark.Analysis.SymbolTable as ST -import Futhark.Optimise.Simplify.Rule -import qualified Futhark.Analysis.AlgSimplify as AS -import qualified Futhark.Analysis.ScalExp as SE -import Futhark.Analysis.PrimExp.Convert -import Futhark.IR.Syntax -import Futhark.Construct -import Futhark.Pass -import Futhark.IR.SOACS (SOACS) -import qualified Futhark.IR.SOACS.Simplify as Simplify -import qualified Futhark.Optimise.Simplify as Simplify - -import Prelude - --- | The assertion-resolver pass. -resolveAssertions :: Pass SOACS SOACS -resolveAssertions = Pass - "resolve assertions" - "Try to statically resolve bounds checks and similar." $ - Simplify.simplifyProg Simplify.simpleSOACS rulebook Simplify.noExtraHoistBlockers - where rulebook = Simplify.soacRules <> ruleBook [ RuleBasicOp simplifyScalExp ] [] - -simplifyScalExp :: BinderOps lore => TopDownRuleBasicOp lore -simplifyScalExp vtable pat _ e = Simplify $ do - res <- SE.toScalExp (`ST.lookupScalExp` vtable) $ BasicOp e - case res of - -- If the sufficient condition is 'True', then it statically succeeds. - Just se - | interesting e, - isNothing $ valOrVar se, - SE.scalExpSize se < size_bound, - Just se' <- valOrVar $ AS.simplify se ranges -> - letBind pat $ BasicOp $ SubExp se' - _ -> cannotSimplify - where ranges = ST.rangesRep vtable - size_bound = 10 -- don't touch scalexps bigger than this. - - valOrVar (SE.Val v) = Just $ Constant v - valOrVar (SE.Id v _) = Just $ Var v - valOrVar _ = Nothing - - interesting CmpOp{} = True - interesting (BinOp LogAnd _ _) = True - interesting (BinOp LogOr _ _) = True - interesting (BinOp _ x y) = isConst x || isConst y - interesting _ = False - - isConst Constant{} = True - isConst Var{} = False diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -25,7 +25,6 @@ import Futhark.Pass.ExtractKernels import Futhark.Pass.FirstOrderTransform import Futhark.Pass.KernelBabysitting -import Futhark.Pass.ResolveAssertions import Futhark.Pass.Simplify import Futhark.Pipeline import Futhark.IR.KernelsMem (KernelsMem) @@ -48,7 +47,6 @@ , fuseSOACs , performCSE True , simplifySOACS - , resolveAssertions , removeDeadFunctions ] diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -655,8 +655,8 @@ -- The program must have been compiled in advance with -- 'compileProgram'. If @runner@ is non-null, then it is used as -- "interpreter" for the compiled program (e.g. @python@ when using --- the Python backends, or @mono@ for the C# backends). The --- @extra_options@ are passed to the program. +-- the Python backends). The @extra_options@ are passed to the +-- program. runProgram :: MonadIO m => String -> [String] -> String -> T.Text -> Values diff --git a/src/Futhark/Tools.hs b/src/Futhark/Tools.hs --- a/src/Futhark/Tools.hs +++ b/src/Futhark/Tools.hs @@ -70,11 +70,10 @@ newIdent (baseString (patElemName pe) ++ "_map_acc") $ acc_t `arrayOfRow` w arrMapPatElem = return . patElemIdent --- | Turn a Screma into simpler Scremas that are all simple scans, --- reduces, and maps. This is used to handle Scremas that are so --- complicated that we cannot directly generate efficient parallel --- code for them. In essense, what happens is the opposite of --- horisontal fusion. +-- | Turn a Screma into a Scanomap (possibly with mapout parts) and a +-- Redomap. This is used to handle Scremas that are so complicated +-- that we cannot directly generate efficient parallel code for them. +-- In essense, what happens is the opposite of horisontal fusion. dissectScrema :: (MonadBinder m, Op (Lore m) ~ SOAC (Lore m), Bindable (Lore m)) => Pattern (Lore m) -> SubExp -> ScremaForm (Lore m) -> [VName] @@ -85,17 +84,14 @@ (scan_res, red_res, map_res) = splitAt3 num_scans num_reds $ patternNames pat - -- First we perform the Map, then we perform the Reduce, and finally - -- the Scan. - to_scan <- replicateM num_scans $ newVName "to_scan" to_red <- replicateM num_reds $ newVName "to_red" - letBindNames (to_scan <> to_red <> map_res) $ Op $ Screma w (mapSOAC map_lam) arrs + let scanomap = scanomapSOAC scans map_lam + letBindNames (scan_res <> to_red <> map_res) $ + Op $ Screma w scanomap arrs + reduce <- reduceSOAC reds letBindNames red_res $ Op $ Screma w reduce to_red - - scan <- scanSOAC scans - letBindNames scan_res $ Op $ Screma w scan to_scan -- | Turn a stream SOAC into statements that apply the stream lambda -- to the entire input. diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs --- a/src/Futhark/Transform/FirstOrderTransform.hs +++ b/src/Futhark/Transform/FirstOrderTransform.hs @@ -27,7 +27,6 @@ import Futhark.IR.SOACS import Futhark.MonadFreshNames import Futhark.Tools -import Futhark.IR.Prop.Aliases import Futhark.Util (chunks, splitAt3) -- | The constraints that must hold for a lore in order to be the @@ -35,16 +34,15 @@ type FirstOrderLore lore = (Bindable lore, BinderOps lore, LetDec SOACS ~ LetDec lore, - LParamInfo SOACS ~ LParamInfo lore, - CanBeAliased (Op lore)) + LParamInfo SOACS ~ LParamInfo lore) -- | First-order-transform a single function, with the given scope -- provided by top-level constants. transformFunDef :: (MonadFreshNames m, FirstOrderLore tolore) => Scope tolore -> FunDef SOACS -> m (AST.FunDef tolore) -transformFunDef consts_scope (FunDef entry fname rettype params body) = do +transformFunDef consts_scope (FunDef entry attrs fname rettype params body) = do (body',_) <- modifyNameSource $ runState $ runBinderT m consts_scope - return $ FunDef entry fname rettype params body' + return $ FunDef entry attrs fname rettype params body' where m = localScope (scopeOfFParams params) $ insertStmsM $ transformBody body -- | First-order-transform these top-level constants. @@ -58,8 +56,7 @@ -- first-order transformation. type Transformer m = (MonadBinder m, LocalScope (Lore m) m, Bindable (Lore m), BinderOps (Lore m), - LParamInfo SOACS ~ LParamInfo (Lore m), - CanBeAliased (Op (Lore m))) + LParamInfo SOACS ~ LParamInfo (Lore m)) transformBody :: (Transformer m, LetDec (Lore m) ~ LetDec SOACS) => Body -> m (AST.Body (Lore m)) @@ -73,13 +70,11 @@ Stm -> m () transformStmRecursively (Let pat aux (Op soac)) = - certifying (stmAuxCerts aux) $ - transformSOAC pat =<< mapSOACM soacTransform soac + auxing aux $ transformSOAC pat =<< mapSOACM soacTransform soac where soacTransform = identitySOACMapper { mapOnSOACLambda = transformLambda } transformStmRecursively (Let pat aux e) = - certifying (stmAuxCerts aux) $ - letBind pat =<< mapExpM transform e + auxing aux $ letBind pat =<< mapExpM transform e where transform = identityMapper { mapOnBody = \scope -> localScope scope . transformBody , mapOnRetType = return , mapOnBranchType = return @@ -169,10 +164,52 @@ <$> replicateM (length scanacc_params) (newVName "discard") letBindNames names $ DoLoop [] merge loopform loop_body -transformSOAC pat (Stream w form lam arrs) = - sequentialStreamWholeArray pat w nes lam arrs - where nes = getStreamAccums form +transformSOAC pat (Stream w stream_form lam arrs) = do + -- Create a loop that repeatedly applies the lambda body to a + -- chunksize of 1. Hopefully this will lead to this outer loop + -- being the only one, as all the innermost one can be simplified + -- array (as they will have one iteration each). + let nes = getStreamAccums stream_form + (chunk_size_param, fold_params, chunk_params) = + partitionChunkedFoldParameters (length nes) $ lambdaParams lam + mapout_merge <- forM (drop (length nes) $ lambdaReturnType lam) $ \t -> + let t' = t `setOuterSize` w + scratch = BasicOp $ Scratch (elemType t') (arrayDims t') + in (,) + <$> newParam "stream_mapout" (toDecl t' Unique) + <*> letSubExp "stream_mapout_scratch" scratch + + let merge = zip (map (fmap (`toDecl` Nonunique)) fold_params) nes ++ + mapout_merge + merge_params = map fst merge + mapout_params = map fst mapout_merge + + i <- newVName "i" + + let loop_form = ForLoop i Int32 w [] + + letBindNames [paramName chunk_size_param] $ + BasicOp $ SubExp $ intConst Int32 1 + + loop_body <- runBodyBinder $ localScope (scopeOf loop_form <> + scopeOfFParams merge_params) $ do + let slice = + [DimSlice (Var i) (Var (paramName chunk_size_param)) (intConst Int32 1)] + forM_ (zip chunk_params arrs) $ \(p, arr) -> + letBindNames [paramName p] $ BasicOp $ Index arr $ + fullSlice (paramType p) slice + + (res, mapout_res) <- splitAt (length nes) <$> bodyBind (lambdaBody lam) + + mapout_res' <- forM (zip mapout_params mapout_res) $ \(p, se) -> + letSubExp "mapout_res" $ BasicOp $ Update (paramName p) + (fullSlice (paramType p) slice) se + + resultBodyM $ res ++ mapout_res' + + letBind pat $ DoLoop [] merge loop_form loop_body + transformSOAC pat (Scatter len lam ivs as) = do iter <- newVName "write_iter" @@ -265,8 +302,7 @@ Bindable lore, BinderOps lore, LocalScope somelore m, SameScope somelore lore, - LetDec lore ~ LetDec SOACS, - CanBeAliased (Op lore)) => + LetDec lore ~ LetDec SOACS) => Lambda -> m (AST.Lambda lore) transformLambda (Lambda params body rettype) = do body' <- runBodyBinder $ diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -170,12 +170,12 @@ descend (stms' <> oneStm stm') rem_stms' instance Renameable lore => Rename (FunDef lore) where - rename (FunDef entry fname ret params body) = + rename (FunDef entry attrs fname ret params body) = bind (map paramName params) $ do params' <- mapM rename params body' <- rename body ret' <- rename ret - return $ FunDef entry fname ret' params' body' + return $ FunDef entry attrs fname ret' params' body' instance Rename SubExp where rename (Var v) = Var <$> rename v diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -354,7 +354,7 @@ expandAliases names env = names <> aliasesOfAliases where aliasesOfAliases = mconcat . map look . namesToList $ names look k = case M.lookup k $ envVtable env of - Just (LetName (als, _)) -> unNames als + Just (LetName (als, _)) -> unAliases als _ -> mempty binding :: Checkable lore => @@ -365,11 +365,11 @@ where bindVars = M.foldlWithKey' bindVar boundnames = M.keys bnds - bindVar env name (LetName (Names' als, dec)) = + bindVar env name (LetName (AliasDec als, dec)) = let als' | primType (typeOf dec) = mempty | otherwise = expandAliases als env in env { envVtable = - M.insert name (LetName (Names' als', dec)) $ envVtable env + M.insert name (LetName (AliasDec als', dec)) $ envVtable env } bindVar env name dec = env { envVtable = M.insert name dec $ envVtable env } @@ -397,7 +397,7 @@ else oneName name <> aliases info aliases :: NameInfo (Aliases lore) -> Names -aliases (LetName (als, _)) = unNames als +aliases (LetName (als, _)) = unAliases als aliases _ = mempty subExpAliasesM :: Checkable lore => SubExp -> TypeM lore Names @@ -470,7 +470,7 @@ where buildFtable = do table <- initialFtable foldM expand table funs - expand ftable (FunDef _ name ret params _) + expand ftable (FunDef _ _ name ret params _) | M.member name ftable = bad $ DupDefinitionError name | otherwise = @@ -486,7 +486,7 @@ checkFun :: Checkable lore => FunDef (Aliases lore) -> TypeM lore () -checkFun (FunDef _ fname rettype params body) = +checkFun (FunDef _ _ fname rettype params body) = context ("In function " ++ nameToString fname) $ checkFun' (fname, map declExtTypeOf rettype, @@ -706,12 +706,6 @@ mapM_ (require [Prim int32]) dims void $ checkSubExp valexp -checkBasicOp (Repeat shapes innershape v) = do - v_t <- lookupType v - mapM_ (mapM_ (require [Prim int32]) . shapeDims) $ innershape : shapes - unless (length shapes == arrayRank v_t) $ - bad $ TypeError "Incorrect number of shapes in repeat." - checkBasicOp (Scratch _ shape) = mapM_ checkSubExp shape @@ -763,6 +757,24 @@ checkBasicOp (Assert e _ _) = require [Prim Bool] e +matchLoopResultExt :: Checkable lore => + [Param DeclType] -> [Param DeclType] + -> [SubExp] -> TypeM lore () +matchLoopResultExt ctx val loopres = do + let rettype_ext = + existentialiseExtTypes (map paramName ctx) $ + staticShapes $ map typeOf $ ctx ++ val + + bodyt <- mapM subExpType loopres + + case instantiateShapes (`maybeNth` loopres) rettype_ext of + Nothing -> bad $ ReturnTypeError (nameFromString "") + rettype_ext (staticShapes bodyt) + Just rettype' -> + unless (bodyt `subtypesOf` rettype') $ + bad $ ReturnTypeError (nameFromString "") + (staticShapes rettype') (staticShapes bodyt) + checkExp :: Checkable lore => Exp (Aliases lore) -> TypeM lore () @@ -842,23 +854,19 @@ staticShapes rettype, funParamsToNameInfos mergepat) consumable $ do checkFunParams mergepat - loopbody_aliases <- checkBody loopbody - - let rettype_ext = existentialiseExtTypes (map paramName mergepat) $ - staticShapes $ map fromDecl rettype + checkBodyLore $ snd $ bodyDec loopbody - bodyt <- extendedScope (traverse subExpType $ bodyResult loopbody) $ - scopeOf $ bodyStms loopbody + checkStms (bodyStms loopbody) $ do + checkResult $ bodyResult loopbody - case instantiateShapes (`maybeNth` bodyResult loopbody) rettype_ext of - Nothing -> bad $ ReturnTypeError (nameFromString "") - (staticShapes $ map fromDecl rettype) (staticShapes bodyt) - Just rettype' -> - unless (bodyt `subtypesOf` rettype') $ - bad $ ReturnTypeError (nameFromString "") - (staticShapes rettype') (staticShapes bodyt) + context "When matching result of body with loop parameters" $ + matchLoopResult (map fst ctxmerge) (map fst valmerge) $ + bodyResult loopbody - return loopbody_aliases + let bound_here = namesFromList $ M.keys $ + scopeOf $ bodyStms loopbody + map (`namesSubtract` bound_here) <$> + mapM subExpAliasesM (bodyResult loopbody) checkExp (Op op) = do checker <- asks envCheckOp checker op @@ -1104,6 +1112,8 @@ primFParam :: VName -> PrimType -> TypeM lore (FParam (Aliases lore)) matchReturnType :: [RetType lore] -> Result -> TypeM lore () matchBranchType :: [BranchType lore] -> Body (Aliases lore) -> TypeM lore () + matchLoopResult :: [FParam (Aliases lore)] -> [FParam (Aliases lore)] + -> [SubExp] -> TypeM lore () default checkExpLore :: ExpDec lore ~ () => ExpDec lore -> TypeM lore () checkExpLore = return @@ -1134,3 +1144,8 @@ default matchBranchType :: BranchType lore ~ ExtType => [BranchType lore] -> Body (Aliases lore) -> TypeM lore () matchBranchType = matchExtBranchType + + default matchLoopResult :: FParamInfo lore ~ DeclType => + [FParam (Aliases lore)] -> [FParam (Aliases lore)] + -> [SubExp] -> TypeM lore () + matchLoopResult = matchLoopResultExt diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -9,6 +9,7 @@ -- compatible). module Futhark.Util (mapAccumLM, + maxinum, chunk, chunks, dropAt, @@ -22,6 +23,7 @@ focusNth, unixEnvironment, isEnvVarSet, + fancyTerminal, runProgramWithExitCode, directoryContents, roundFloat, ceilFloat, floorFloat, @@ -46,10 +48,11 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import Data.Char -import Data.List (genericDrop, genericSplitAt) +import Data.List (foldl', genericDrop, genericSplitAt) import Data.Either import Data.Maybe import System.Environment +import System.IO (hIsTerminalDevice, stdout) import System.IO.Unsafe import qualified System.Directory.Tree as Dir import System.Process.ByteString @@ -84,6 +87,10 @@ let (bef,aft) = splitAt n xs in bef : chunks ns aft +-- | Like 'maximum', but returns zero for an empty list. +maxinum :: (Num a, Ord a, Foldable f) => f a -> a +maxinum = foldl' max 0 + -- | @dropAt i n@ drops @n@ elements starting at element @i@. dropAt :: Int -> Int -> [a] -> [a] dropAt i n xs = take i xs ++ drop (i+n) xs @@ -144,6 +151,15 @@ "1" -> return True _ -> Nothing +{-# NOINLINE fancyTerminal #-} +-- | Are we running in a terminal capable of fancy commands and +-- visualisation? +fancyTerminal :: Bool +fancyTerminal = unsafePerformIO $ do + isTTY <- hIsTerminalDevice stdout + isDumb <- (Just "dumb" ==) <$> lookupEnv "TERM" + return $ isTTY && not isDumb + -- | Like 'readProcessWithExitCode', but also wraps exceptions when -- the indicated binary cannot be launched, or some other exception is -- thrown. Also does shenanigans to handle improperly encoded outputs. @@ -153,8 +169,8 @@ (Right . postprocess <$> readProcessWithExitCode exe args inp) `catch` \e -> return (Left e) where decode = T.unpack . T.decodeUtf8With T.lenientDecode - postprocess (err, stdout, stderr) = - (err, decode stdout, decode stderr) + postprocess (code, out, err) = + (code, decode out, decode err) -- | Every non-directory file contained in a directory tree. directoryContents :: FilePath -> IO [FilePath] diff --git a/src/Futhark/Util/IntegralExp.hs b/src/Futhark/Util/IntegralExp.hs --- a/src/Futhark/Util/IntegralExp.hs +++ b/src/Futhark/Util/IntegralExp.hs @@ -17,7 +17,6 @@ module Futhark.Util.IntegralExp ( IntegralExp (..) , Wrapped (..) - , quotRoundingUp ) where @@ -33,6 +32,12 @@ mod :: e -> e -> e sgn :: e -> Maybe Int + -- | Like 'Futhark.Util.IntegralExp.div', but rounds towards + -- positive infinity. + divUp :: e -> e -> e + divUp x y = + (x + y - 1) `Futhark.Util.IntegralExp.div` y + fromInt8 :: Int8 -> e fromInt16 :: Int16 -> e fromInt32 :: Int32 -> e @@ -71,8 +76,3 @@ fromInt16 = fromInteger . toInteger fromInt32 = fromInteger . toInteger fromInt64 = fromInteger . toInteger - --- | Like 'Prelude.quot', but rounds up. -quotRoundingUp :: IntegralExp num => num -> num -> num -quotRoundingUp x y = - (x + y - 1) `Futhark.Util.IntegralExp.quot` y diff --git a/src/Futhark/Util/Table.hs b/src/Futhark/Util/Table.hs --- a/src/Futhark/Util/Table.hs +++ b/src/Futhark/Util/Table.hs @@ -8,6 +8,7 @@ import Data.List (intercalate, transpose) import System.Console.ANSI +import Futhark.Util (maxinum) import Futhark.Util.Console (color) data RowTemplate = RowTemplate [Int] Int deriving (Show) @@ -23,7 +24,7 @@ buildRowTemplate :: [[Entry]] -> Int -> RowTemplate buildRowTemplate rows = RowTemplate widths - where widths = map (maximum . map (length . fst)) . transpose $ rows + where widths = map (maxinum . map (length . fst)) . transpose $ rows buildRow :: RowTemplate -> [Entry] -> String buildRow (RowTemplate widths pad) entries = cells ++ "\n" 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 @@ -13,6 +13,7 @@ , interpretImport , interpretFunction , ExtOp(..) + , BreakReason(..) , StackFrame(..) , typeCheckerEnv , Value (ValuePrim, ValueArray, ValueRecord) @@ -54,13 +55,18 @@ instance Located StackFrame where locOf = stackFrameLoc +-- | What is the reason for this break point? +data BreakReason + = BreakPoint -- ^ An explicit breakpoint in the program. + | BreakNaN -- ^ A + data ExtOp a = ExtOpTrace Loc String a - | ExtOpBreak (NE.NonEmpty StackFrame) a + | ExtOpBreak BreakReason (NE.NonEmpty StackFrame) a | ExtOpError InterpreterError instance Functor ExtOp where fmap f (ExtOpTrace w s x) = ExtOpTrace w s $ f x - fmap f (ExtOpBreak backtrace x) = ExtOpBreak backtrace $ f x + fmap f (ExtOpBreak why backtrace x) = ExtOpBreak why backtrace $ f x fmap _ (ExtOpError err) = ExtOpError err type Stack = [StackFrame] @@ -413,7 +419,7 @@ backtrace <- asks $ drop 1 . fst case NE.nonEmpty backtrace of Nothing -> return () - Just backtrace' -> liftF $ ExtOpBreak backtrace' () + Just backtrace' -> liftF $ ExtOpBreak BreakPoint backtrace' () fromArray :: Value -> (ValueShape, [Value]) fromArray (ValueArray shape as) = (shape, elems as) @@ -447,16 +453,12 @@ valEnv (M.singleton v (Just $ T.BoundV [] $ toStruct t, val)) <> env patternMatch env Wildcard{} _ = lift $ pure env -patternMatch env (TuplePattern ps _) (ValueRecord vs) - | length ps == length vs' = - foldM (\env' (p,v) -> patternMatch env' p v) env $ - zip ps (map snd $ sortFields vs) - where vs' = sortFields vs -patternMatch env (RecordPattern ps _) (ValueRecord vs) - | length ps == length vs' = - foldM (\env' (p,v) -> patternMatch env' p v) env $ - zip (map snd $ sortFields $ M.fromList ps) (map snd $ sortFields vs) - where vs' = sortFields vs +patternMatch env (TuplePattern ps _) (ValueRecord vs) = + foldM (\env' (p,v) -> patternMatch env' p v) env $ + zip ps (map snd $ sortFields vs) +patternMatch env (RecordPattern ps _) (ValueRecord vs) = + foldM (\env' (p,v) -> patternMatch env' p v) env $ + M.intersectionWith (,) (M.fromList ps) vs patternMatch env (PatternParens p _) v = patternMatch env p v patternMatch env (PatternAscription p _ _) v = patternMatch env p v @@ -969,8 +971,6 @@ ValueRecord fs | Just v' <- M.lookup f fs -> return v' _ -> error "Value does not have expected field." -eval env (Unsafe e _) = eval env e - eval env (Assert what e (Info s) loc) = do cond <- asBool <$> eval env what unless cond $ bad loc env s @@ -1069,7 +1069,7 @@ evalDec :: Env -> Dec -> EvalM Env -evalDec env (ValDec (ValBind _ v _ (Info (ret, retext)) tparams ps fbody _ _)) = do +evalDec env (ValDec (ValBind _ v _ (Info (ret, retext)) tparams ps fbody _ _ _)) = do binding <- evalFunctionBinding env tparams ps ret retext fbody return $ env { envTerm = M.insert v binding $ envTerm env } @@ -1104,6 +1104,22 @@ , ctxImports :: M.Map FilePath Env } +nanValue :: PrimValue -> Bool +nanValue (FloatValue v) = + case v of Float32Value x -> isNaN x + Float64Value x -> isNaN x +nanValue _ = False + +breakOnNaN :: [PrimValue] -> PrimValue -> EvalM () +breakOnNaN inputs result + | not (any nanValue inputs) && nanValue result = do + backtrace <- asks fst + case NE.nonEmpty backtrace of + Nothing -> return () + Just backtrace' -> liftF $ ExtOpBreak BreakNaN backtrace' () +breakOnNaN _ _ = + return () + -- | The initial environment contains definitions of the various intrinsic functions. initialCtx :: Ctx initialCtx = @@ -1192,7 +1208,8 @@ bopDef fs = fun2 $ \x y -> case (x, y) of (ValuePrim x', ValuePrim y') - | Just z <- msum $ map (`bopDef'` (x', y')) fs -> + | Just z <- msum $ map (`bopDef'` (x', y')) fs -> do + breakOnNaN [x', y'] z return $ ValuePrim z _ -> bad noLoc mempty $ "Cannot apply operator to arguments " <> @@ -1205,7 +1222,8 @@ unopDef fs = fun1 $ \x -> case x of (ValuePrim x') - | Just r <- msum $ map (`unopDef'` x') fs -> + | Just r <- msum $ map (`unopDef'` x') fs -> do + breakOnNaN [x'] r return $ ValuePrim r _ -> bad noLoc mempty $ "Cannot apply function to argument " <> @@ -1219,8 +1237,9 @@ Just [ValuePrim x, ValuePrim y] | Just x' <- getV x, Just y' <- getV y, - Just z <- f x' y' -> - return $ ValuePrim $ putV z + Just z <- putV <$> f x' y' -> do + breakOnNaN [x, y] z + return $ ValuePrim z _ -> bad noLoc mempty $ "Cannot apply operator to argument " <> quote (pretty v) <> "." @@ -1239,10 +1258,20 @@ def "-" = arithOp (`P.Sub` P.OverflowWrap) P.FSub def "*" = arithOp (`P.Mul` P.OverflowWrap) P.FMul def "**" = arithOp P.Pow P.FPow - def "/" = Just $ bopDef $ sintOp P.SDiv ++ uintOp P.UDiv ++ floatOp P.FDiv - def "%" = Just $ bopDef $ sintOp P.SMod ++ uintOp P.UMod ++ floatOp P.FMod - def "//" = Just $ bopDef $ sintOp P.SQuot ++ uintOp P.UDiv - def "%%" = Just $ bopDef $ sintOp P.SRem ++ uintOp P.UMod + def "/" = Just $ bopDef $ + sintOp (`P.SDiv` P.Unsafe) ++ + uintOp (`P.UDiv` P.Unsafe) ++ + floatOp P.FDiv + def "%" = Just $ bopDef $ + sintOp (`P.SMod` P.Unsafe) ++ + uintOp (`P.UMod` P.Unsafe) ++ + floatOp P.FMod + def "//" = Just $ bopDef $ + sintOp (`P.SQuot` P.Unsafe) ++ + uintOp (`P.UDiv` P.Unsafe) + def "%%" = Just $ bopDef $ + sintOp (`P.SRem` P.Unsafe) ++ + uintOp (`P.UMod` P.Unsafe) def "^" = Just $ bopDef $ intOp P.Xor def "&" = Just $ bopDef $ intOp P.And def "|" = Just $ bopDef $ intOp P.Or @@ -1288,11 +1317,13 @@ case length pts of 1 -> Just $ unopDef [(getV, Just . putV, f . pure)] _ -> Just $ fun1 $ \x -> do - let getV' (ValuePrim v) = getV v + let getV' (ValuePrim v) = Just v getV' _ = Nothing - case f =<< mapM getV' =<< fromTuple x of - Just res -> - return $ ValuePrim $ putV res + case mapM getV' =<< fromTuple x of + Just vs + | Just res <- fmap putV . f =<< mapM getV vs -> do + breakOnNaN vs res + return $ ValuePrim res _ -> error $ "Cannot apply " ++ pretty s ++ " to " ++ pretty x diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x --- a/src/Language/Futhark/Parser/Lexer.x +++ b/src/Language/Futhark/Parser/Lexer.x @@ -14,13 +14,16 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Char (ord, toLower) +import qualified Data.Text.Read as T +import Data.Char (ord, toLower, digitToInt) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8) import Data.Bits import Data.Function (fix) import Data.List import Data.Monoid +import Data.Either +import Numeric import Language.Futhark.Core (Int8, Int16, Int32, Int64, Word8, Word16, Word32, Word64, @@ -51,12 +54,12 @@ @unop = "!" @qualunop = (@identifier ".")+ @unop -@opchar = ("+"|"-"|"*"|"/"|"%"|"="|"!"|">"|"<"|"|"|"&"|"^"|".") -@binop = ("+"|"-"|"*"|"/"|"%"|"="|"!"|">"|"<"|"|"|"&"|"^") @opchar* +$opchar = [\+\-\*\/\%\=\!\>\<\|\&\^\.] +@binop = ($opchar # \.) $opchar* @qualbinop = (@identifier ".")+ @binop @space = [\ \t\f\v] -@doc = "-- |"[^\n]*(\n@space*"--"[^\n]*)* +@doc = "-- |".*(\n@space*"--".*)* tokens :- @@ -65,7 +68,7 @@ map (T.drop 3 . T.stripStart) . T.split (== '\n') . ("--"<>) . T.drop 4 } - "--"[^\n]* ; + "--".* ; "=" { tokenC EQU } "(" { tokenC LPAR } ")" { tokenC RPAR } @@ -104,9 +107,9 @@ @reallit f32 { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } @reallit f64 { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } @reallit { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') } - @hexreallit f32 { tokenM $ fmap F32LIT . readHexRealLit "f32" . suffZero . T.filter (/= '_') . fst . T.breakOn (T.pack "f32") } - @hexreallit f64 { tokenM $ fmap F64LIT . readHexRealLit "f64" . suffZero . T.filter (/= '_') . fst . T.breakOn (T.pack "f64") } - @hexreallit { tokenM $ fmap FLOATLIT . readHexRealLit "f64" . suffZero . T.filter (/= '_') . fst . T.breakOn (T.pack "f64") } + @hexreallit f32 { tokenM $ fmap F32LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } + @hexreallit f64 { tokenM $ fmap F64LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } + @hexreallit { tokenM $ fmap FLOATLIT . readHexRealLit . T.filter (/= '_') } "'" @charlit "'" { tokenM $ fmap CHARLIT . tryRead "char" } \" @stringcharlit* \" { tokenM $ fmap STRINGLIT . tryRead "string" } @@ -150,7 +153,6 @@ "entry" -> ENTRY "module" -> MODULE "while" -> WHILE - "unsafe" -> UNSAFE "assert" -> ASSERT "match" -> MATCH "case" -> CASE @@ -179,20 +181,11 @@ readIntegral :: Integral a => T.Text -> a readIntegral s - | "0x" `T.isPrefixOf` s || "0X" `T.isPrefixOf` s = - T.foldl (another hex_digits) 0 (T.drop 2 s) - | "0b" `T.isPrefixOf` s || "0b" `T.isPrefixOf` s = - T.foldl (another binary_digits) 0 (T.drop 2 s) - | "0r" `T.isPrefixOf` s = - fromRoman (T.drop 2 s) - | otherwise = - T.foldl (another decimal_digits) 0 s - where another digits acc c = acc * base + maybe 0 fromIntegral (elemIndex (toLower c) digits) - where base = fromIntegral $ length digits - - binary_digits = ['0', '1'] - decimal_digits = ['0'..'9'] - hex_digits = decimal_digits ++ ['a'..'f'] + | "0x" `T.isPrefixOf` s || "0X" `T.isPrefixOf` s = parseBase 16 (T.drop 2 s) + | "0b" `T.isPrefixOf` s || "0B" `T.isPrefixOf` s = parseBase 2 (T.drop 2 s) + | "0r" `T.isPrefixOf` s || "0R" `T.isPrefixOf` s = fromRoman (T.drop 2 s) + | otherwise = parseBase 10 s + where parseBase base = T.foldl (\acc c -> acc * base + fromIntegral (digitToInt c)) 0 tokenC v = tokenS $ const v @@ -251,30 +244,23 @@ Nothing -> 0 Just (d,n) -> n+fromRoman (T.drop (T.length d) s) -fromHexRealLit :: RealFloat a => T.Text -> Maybe a -fromHexRealLit s = +readHexRealLit :: RealFloat a => T.Text -> Alex a +readHexRealLit s = let num = (T.drop 2 s) in -- extract number into integer, fractional and (optional) exponent - let comps = (T.split (\x -> x == '.' || x == 'p' || x == 'P') num) in + let comps = T.split (`elem` ['.','p','P']) num in case comps of [i, f, p] -> - let int_part = readIntegral (T.pack ("0x" ++ (T.unpack i))) - frac_part = readIntegral (T.pack ("0x" ++ (T.unpack f))) - exponent = if ((T.pack "-") `T.isPrefixOf` p) - then -1 * (readIntegral p) - else readIntegral p - - frac_len = T.length f - frac_val = (fromIntegral frac_part) / (16.0 ** (fromIntegral frac_len)) - total_val = ((fromIntegral int_part) + frac_val) * (2.0 ** (fromIntegral exponent)) in - Just (total_val) - _ -> Nothing + let runTextReader r = fromIntegral . fst . fromRight (error "internal error") . r + intPart = runTextReader T.hexadecimal i + fracPart = runTextReader T.hexadecimal f + exponent = runTextReader (T.signed T.decimal) p -readHexRealLit :: RealFloat a => String -> T.Text -> Alex a -readHexRealLit desc s = - case fromHexRealLit s of - Just (n) -> return n - Nothing -> error $ "Invalid " ++ desc ++ " literal: " ++ T.unpack s + fracLen = fromIntegral $ T.length f + fracVal = fracPart / (16.0 ** fracLen) + totalVal = (intPart + fracVal) * (2.0 ** exponent) in + return totalVal + _ -> error "bad hex real literal" alexGetPosn :: Alex (Int, Int, Int) alexGetPosn = Alex $ \s -> @@ -363,7 +349,6 @@ | FOR | DO | WITH - | UNSAFE | ASSERT | TRUE | FALSE diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -154,7 +154,6 @@ for { L $$ FOR } do { L $$ DO } with { L $$ WITH } - unsafe { L $$ UNSAFE } assert { L $$ ASSERT } true { L $$ TRUE } false { L $$ FALSE } @@ -169,7 +168,7 @@ doc { L _ (DOC _) } %left bottom -%left ifprec letprec unsafe caseprec typeprec enumprec sumprec +%left ifprec letprec caseprec typeprec enumprec sumprec %left ',' case id constructor '(' '{' %right ':' ':>' %right '...' '..<' '..>' '..' @@ -225,6 +224,9 @@ | import stringlit { let L _ (STRINGLIT s) = $2 in ImportDec s NoInfo (srcspan $1 $>) } | local Dec { LocalDec $2 (srcspan $1 $>) } + | '#[' AttrInfo ']' Dec_ + { addAttr $2 $4 } + ; SigExp :: { UncheckedSigExp } @@ -319,6 +321,8 @@ { IncludeSpec $2 (srcspan $1 $>) } | Doc Spec { addDocSpec $1 $2 } + | '#[' AttrInfo ']' Spec + { addAttrSpec $2 $4 } Specs :: { [SpecBase NoInfo Name] } : Spec Specs { $1 : $2 } @@ -392,22 +396,22 @@ Val : let BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp { let (name, _) = $2 in ValBind (if name==defaultEntryPoint then Just NoInfo else Nothing) name (fmap declaredType $5) NoInfo - $3 $4 $7 Nothing (srcspan $1 $>) + $3 $4 $7 Nothing mempty (srcspan $1 $>) } | entry BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp { let (name, loc) = $2 in ValBind (Just NoInfo) name (fmap declaredType $5) NoInfo - $3 $4 $7 Nothing (srcspan $1 $>) } + $3 $4 $7 Nothing mempty (srcspan $1 $>) } | let FunParam BindingBinOp FunParam maybeAscription(TypeExpDecl) '=' Exp - { ValBind Nothing $3 (fmap declaredType $5) NoInfo [] [$2,$4] $7 Nothing (srcspan $1 $>) + { ValBind Nothing $3 (fmap declaredType $5) NoInfo [] [$2,$4] $7 + Nothing mempty (srcspan $1 $>) } | let BindingUnOp TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp - { let name = $2 - in ValBind Nothing name (fmap declaredType $5) NoInfo - $3 $4 $7 Nothing (srcspan $1 $>) + { ValBind Nothing $2 (fmap declaredType $5) NoInfo $3 $4 $7 + Nothing mempty (srcspan $1 $>) } TypeExpDecl :: { TypeDeclBase NoInfo Name } @@ -548,7 +552,6 @@ | MatchExp { $1 } - | unsafe Exp2 { Unsafe $2 (srcspan $1 $>) } | assert Atom Atom { Assert $2 $3 NoInfo (srcspan $1 $>) } | '#[' AttrInfo ']' Exp %prec bottom { Attr $2 $4 (srcspan $1 $>) } @@ -887,9 +890,14 @@ | { Nothing } AttrInfo :: { AttrInfo } - : id { let L _ (ID s) = $1 in AttrInfo s } - | unsafe { AttrInfo "unsafe" } -- HACK + : id { let L _ (ID s) = $1 in AttrAtom s } + | id '(' ')' { let L _ (ID s) = $1 in AttrComp s [] } + | id '(' Attrs ')' { let L _ (ID s) = $1 in AttrComp s $3 } +Attrs :: { [AttrInfo] } + : AttrInfo { [$1] } + | AttrInfo ',' Attrs { $1 : $3 } + Value :: { Value } Value : IntValue { $1 } | FloatValue { $1 } @@ -993,6 +1001,16 @@ addDocSpec doc (TypeSpec l name ps _ loc) = TypeSpec l name ps (Just doc) loc addDocSpec doc (ModSpec name se _ loc) = ModSpec name se (Just doc) loc addDocSpec _ spec = spec + +addAttr :: AttrInfo -> UncheckedDec -> UncheckedDec +addAttr attr (ValDec val) = + ValDec $ val { valBindAttrs = attr : valBindAttrs val } +addAttr attr dec = + dec + +-- We will extend this function once we actually start tracking these. +addAttrSpec :: AttrInfo -> UncheckedSpec -> UncheckedSpec +addAttrSpec _attr dec = dec reverseNonempty :: (a, [a]) -> (a, [a]) reverseNonempty (x, l) = diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -303,7 +303,6 @@ text "=" <+> align (ppr ve) pprPrec _ (Index e idxs _ _) = pprPrec 9 e <> brackets (commasep (map ppr idxs)) - pprPrec _ (Unsafe e _) = text "unsafe" <+> pprPrec (-1) e pprPrec _ (Assert e1 e2 _ _) = text "assert" <+> pprPrec 10 e1 <+> pprPrec 10 e2 pprPrec p (Lambda params body rettype _ _) = parensIf (p /= -1) $ @@ -328,10 +327,11 @@ pprPrec _ (Constr n cs _ _) = text "#" <> ppr n <+> sep (map ppr cs) pprPrec _ (Match e cs _ _) = text "match" <+> ppr e (stack . map ppr) (NE.toList cs) pprPrec _ (Attr attr e _) = - text "#[" <> ppr attr <> text "]" <+/> pprPrec (-1) e + text "#[" <> ppr attr <> text "]" pprPrec (-1) e instance Pretty AttrInfo where - ppr (AttrInfo attr) = ppr attr + ppr (AttrAtom attr) = ppr attr + ppr (AttrComp f attrs) = ppr f <> parens (commasep $ map ppr attrs) instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where ppr (RecordFieldExplicit name e _) = ppr name <> equals <> ppr e @@ -407,7 +407,8 @@ ppr (TypeParamType l name _) = text "'" <> ppr l <> pprName name instance (Eq vn, IsName vn, Annot f) => Pretty (ValBindBase f vn) where - ppr (ValBind entry name retdecl rettype tparams args body _ _) = + ppr (ValBind entry name retdecl rettype tparams args body _ attrs _) = + mconcat (map ((<> line) . ppr) attrs) <> text fun <+> pprName name <+> align (sep (map ppr tparams ++ map ppr args)) <> retdecl' <> text " =" indent 2 (ppr body) 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 @@ -100,13 +100,13 @@ , UncheckedPattern , UncheckedValBind , UncheckedDec + , UncheckedSpec , UncheckedProg , UncheckedCase ) where import Control.Monad.State -import Control.Monad.Writer hiding (Sum) import Data.Char import Data.Foldable import qualified Data.Map.Strict as M @@ -118,8 +118,7 @@ import Data.Bifoldable import Data.Bitraversable (bitraverse) -import Prelude - +import Futhark.Util (maxinum) import Futhark.Util.Pretty import Language.Futhark.Syntax @@ -183,36 +182,49 @@ -- | Perform a traversal (possibly including replacement) on sizes -- that are parameters in a function type, but also including the type --- immediately passed to the function. +-- immediately passed to the function. Also passes along a set of the +-- parameter names inside the type that have come in scope at the +-- occurrence of the dimension. traverseDims :: forall f fdim tdim als. Applicative f => - (DimPos -> fdim -> f tdim) + (S.Set VName -> DimPos -> fdim -> f tdim) -> TypeBase fdim als -> f (TypeBase tdim als) -traverseDims f = go PosImmediate - where go :: forall als'. DimPos -> TypeBase fdim als' -> f (TypeBase tdim als') - go b t@Array{} = bitraverse (f b) pure t - go b (Scalar (Record fields)) = Scalar . Record <$> traverse (go b) fields - go b (Scalar (TypeVar as u tn targs)) = - Scalar <$> (TypeVar as u tn <$> traverse (onTypeArg b) targs) - go b (Scalar (Sum cs)) = Scalar . Sum <$> traverse (traverse (go b)) cs - go _ (Scalar (Prim t)) = pure $ Scalar $ Prim t - go _ (Scalar (Arrow als p t1 t2)) = - Scalar <$> (Arrow als p <$> go PosParam t1 <*> go PosReturn t2) +traverseDims f = go mempty PosImmediate + where go :: forall als'. + S.Set VName -> DimPos -> TypeBase fdim als' + -> f (TypeBase tdim als') + go bound b t@Array{} = + bitraverse (f bound b) pure t + go bound b (Scalar (Record fields)) = + Scalar . Record <$> traverse (go bound b) fields + go bound b (Scalar (TypeVar as u tn targs)) = + Scalar <$> (TypeVar as u tn <$> traverse (onTypeArg bound b) targs) + go bound b (Scalar (Sum cs)) = + Scalar . Sum <$> traverse (traverse (go bound b)) cs + go _ _ (Scalar (Prim t)) = + pure $ Scalar $ Prim t + go bound _ (Scalar (Arrow als p t1 t2)) = + Scalar <$> (Arrow als p <$> go bound' PosParam t1 <*> go bound' PosReturn t2) + where bound' = case p of Named p' -> S.insert p' bound + Unnamed -> bound - onTypeArg b (TypeArgDim d loc) = - TypeArgDim <$> f b d <*> pure loc - onTypeArg b (TypeArgType t loc) = - TypeArgType <$> go b t <*> pure loc + onTypeArg bound b (TypeArgDim d loc) = + TypeArgDim <$> f bound b d <*> pure loc + onTypeArg bound b (TypeArgType t loc) = + TypeArgType <$> go bound b t <*> pure loc mustBeExplicitAux :: StructType -> M.Map VName Bool mustBeExplicitAux t = execState (traverseDims onDim t) mempty - where onDim PosImmediate (NamedDim d) = + where onDim bound _ (NamedDim d) + | qualLeaf d `S.member` bound = + modify $ \s -> M.insertWith (&&) (qualLeaf d) False s + onDim _ PosImmediate (NamedDim d) = modify $ \s -> M.insertWith (&&) (qualLeaf d) False s - onDim _ (NamedDim d) = + onDim _ _ (NamedDim d) = modify $ M.insertWith (&&) (qualLeaf d) True - onDim _ _ = + onDim _ _ _ = return () -- | Figure out which of the sizes in a parameter type must be passed @@ -541,7 +553,6 @@ typeOf (Index _ _ (Info t, _) _) = t typeOf (Update e _ _ _) = typeOf e `setAliases` mempty typeOf (RecordUpdate _ _ _ (Info t) _) = t -typeOf (Unsafe e _) = typeOf e typeOf (Assert _ e _ _) = typeOf e typeOf (DoLoop _ _ _ _ _ (Info (t, _)) _) = t typeOf (Lambda params _ _ (Info (als, t)) _) = @@ -919,7 +930,7 @@ -- | The largest tag used by an intrinsic - this can be used to -- determine whether a 'VName' refers to an intrinsic or a user-defined name. maxIntrinsicTag :: Int -maxIntrinsicTag = maximum $ map baseTag $ M.keys intrinsics +maxIntrinsicTag = maxinum $ map baseTag $ M.keys intrinsics -- | Create a name with no qualifiers from a name. qualName :: v -> QualName v @@ -1048,6 +1059,9 @@ -- | A declaration with no type annotations. type UncheckedDec = DecBase NoInfo Name + +-- | A spec with no type annotations. +type UncheckedSpec = SpecBase NoInfo Name -- | A Futhark program with no type annotations. type UncheckedProg = ProgBase NoInfo Name 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 @@ -204,7 +204,9 @@ primValue = BoolValue -- | The payload of an attribute. -newtype AttrInfo = AttrInfo Name +data AttrInfo + = AttrAtom Name + | AttrComp Name [AttrInfo] deriving (Eq, Ord, Show) -- | A type class for things that can be array dimensions. @@ -720,12 +722,6 @@ | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f PatternType) SrcLoc - | Unsafe (ExpBase f vn) SrcLoc - -- ^ Explore the Danger Zone and elide safety checks on - -- array operations and other assertions during execution - -- of this expression. Make really sure the code is - -- correct. - | Assert (ExpBase f vn) (ExpBase f vn) (f String) SrcLoc -- ^ Fail if the first expression does not return true, -- and return the value of the second expression if it @@ -777,7 +773,6 @@ locOf (ProjectSection _ _ loc) = locOf loc locOf (IndexSection _ _ loc) = locOf loc locOf (DoLoop _ _ _ _ _ _ loc) = locOf loc - locOf (Unsafe _ loc) = locOf loc locOf (Assert _ _ _ loc) = locOf loc locOf (Constr _ _ _ loc) = locOf loc locOf (Match _ _ _ loc) = locOf loc @@ -875,6 +870,7 @@ , valBindParams :: [PatternBase f vn] , valBindBody :: ExpBase f vn , valBindDoc :: Maybe DocComment + , valBindAttrs :: [AttrInfo] , valBindLocation :: SrcLoc } deriving instance Showable f vn => Show (ValBindBase f vn) diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -132,8 +132,6 @@ astMap tv (Index arr idxexps (t, ext) loc) = Index <$> mapOnExp tv arr <*> mapM (astMap tv) idxexps <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc - astMap tv (Unsafe e loc) = - Unsafe <$> mapOnExp tv e <*> pure loc astMap tv (Assert e1 e2 desc loc) = Assert <$> mapOnExp tv e1 <*> mapOnExp tv e2 <*> pure desc <*> pure loc astMap tv (Lambda params body ret t loc) = @@ -403,7 +401,6 @@ bareExp (Project field e _ loc) = Project field (bareExp e) NoInfo loc bareExp (Index arr slice _ loc) = Index (bareExp arr) (map bareDimIndex slice) (NoInfo, NoInfo) loc -bareExp (Unsafe e loc) = Unsafe (bareExp e) loc bareExp (Assert e1 e2 _ loc) = Assert (bareExp e1) (bareExp e2) NoInfo loc bareExp (Lambda params body ret _ loc) = Lambda (map barePat params) (bareExp body) ret NoInfo loc 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 @@ -143,8 +143,8 @@ dupDefinitionError namespace name loc loc' _ -> return $ M.insert (namespace, name) loc known - f (ValDec (ValBind _ name _ _ _ _ _ _ loc)) = - check Term name loc + f (ValDec vb) = + check Term (valBindName vb) (srclocOf vb) f (TypeDec (TypeBind name _ _ _ _ loc)) = check Type name loc @@ -173,8 +173,8 @@ emptyDimParam :: StructType -> Bool emptyDimParam = isNothing . traverseDims onDim - where onDim pos AnyDim | pos `elem` [PosImmediate, PosParam] = Nothing - onDim _ d = Just d + where onDim _ pos AnyDim | pos `elem` [PosImmediate, PosParam] = Nothing + onDim _ _ d = Just d -- In this function, after the recursion, we add the Env of the -- current Spec *after* the one that is returned from the recursive @@ -515,7 +515,7 @@ ([], EntryType t te) checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind) -checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc loc) = do +checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc attrs loc) = do (fname', tparams', params', maybe_tdecl', rettype, retext, body') <- checkFunDef (fname, maybe_tdecl, tparams, params, body, loc) @@ -558,7 +558,7 @@ , envNameMap = M.singleton (Term, fname) $ qualName fname' }, - ValBind entry' fname' maybe_tdecl' (Info (rettype, retext)) tparams' params' body' doc loc) + ValBind entry' fname' maybe_tdecl' (Info (rettype, retext)) tparams' params' body' doc attrs loc) nastyType :: Monoid als => TypeBase dim als -> Bool nastyType (Scalar Prim{}) = False 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 @@ -254,8 +254,8 @@ emptyDims :: StructType -> Bool emptyDims = isNothing . traverseDims onDim - where onDim PosImmediate AnyDim = Nothing - onDim _ d = Just d + where onDim _ PosImmediate AnyDim = Nothing + onDim _ _ d = Just d resolveMTyNames :: MTy -> MTy -> M.Map VName (QualName VName) @@ -434,13 +434,17 @@ unless (length spec_ps == length ps) $ nomatch spec_t param_substs <- mconcat <$> zipWithM matchTypeParam spec_ps ps - case S.toList (mustBeExplicitInType t) `intersect` map typeParamName ps of - [] -> return () - d:_ -> Left $ TypeError loc mempty $ - "Type" - indent 2 (ppTypeAbbr [] name (l, ps, t)) - textwrap "cannot be made abstract because size parameter" <+/> pquote (pprName d) <+/> - textwrap "is not used as an array size in the definition." + -- Abstract types have a particular restriction to ensure that + -- if we have a value of an abstract type 't [n]', then there is + -- an array of size 'n' somewhere inside. + when (M.member spec_name abs_subst_to_type) $ + case S.toList (mustBeExplicitInType t) `intersect` map typeParamName ps of + [] -> return () + d:_ -> Left $ TypeError loc mempty $ + "Type" + indent 2 (ppTypeAbbr [] name (l, ps, t)) + textwrap "cannot be made abstract because size parameter" <+/> pquote (pprName d) <+/> + textwrap "is not used as an array size in the definition." let spec_t' = substituteTypes (param_substs<>abs_subst_to_type) spec_t if spec_t' == t 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 @@ -55,10 +55,9 @@ import Control.Monad.Except import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.Writer hiding (Sum) import Control.Monad.State -import Control.Monad.RWS.Strict -import Control.Monad.Identity +import Control.Monad.RWS.Strict hiding (Sum) import Data.List (isPrefixOf, find) import Data.Maybe import Data.Either @@ -69,7 +68,6 @@ import Language.Futhark import Language.Futhark.Semantic -import Language.Futhark.Traversals import Language.Futhark.Warnings import Futhark.FreshNames hiding (newName) import qualified Futhark.FreshNames @@ -313,15 +311,38 @@ -- | Try to prepend qualifiers to the type names such that they -- represent how to access the type in some scope. -qualifyTypeVars :: ASTMappable t => Env -> [VName] -> [VName] -> t -> t -qualifyTypeVars outer_env except ref_qs = runIdentity . astMap mapper - where mapper = ASTMapper { mapOnExp = pure - , mapOnName = pure - , mapOnQualName = pure . qual - , mapOnStructType = pure - , mapOnPatternType = pure - } - qual (QualName orig_qs name) +qualifyTypeVars :: Env -> [VName] -> [VName] -> TypeBase (DimDecl VName) as + -> TypeBase (DimDecl VName) as +qualifyTypeVars outer_env orig_except ref_qs = onType (S.fromList orig_except) + where onType :: S.Set VName -> TypeBase (DimDecl VName) as + -> TypeBase (DimDecl VName) as + onType except (Array as u et shape) = + Array as u (onScalar except et) (fmap (onDim except) shape) + onType except (Scalar t) = + Scalar $ onScalar except t + + onScalar _ (Prim t) = Prim t + onScalar except (TypeVar as u tn targs) = + TypeVar as u tn' $ map (onTypeArg except) targs + where tn' = typeNameFromQualName $ qual except $ qualNameFromTypeName tn + onScalar except (Record m) = + Record $ M.map (onType except) m + onScalar except (Sum m) = + Sum $ M.map (map $ onType except) m + onScalar except (Arrow as p t1 t2) = + Arrow as p (onType except' t1) (onType except' t2) + where except' = case p of Named p' -> S.insert p' except + Unnamed -> except + + onTypeArg except (TypeArgDim d loc) = + TypeArgDim (onDim except d) loc + onTypeArg except (TypeArgType t loc) = + TypeArgType (onType except t) loc + + onDim except (NamedDim qn) = NamedDim $ qual except qn + onDim _ d = d + + qual except (QualName orig_qs name) | name `elem` except || reachable orig_qs name outer_env = QualName orig_qs name | otherwise = 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 @@ -1087,12 +1087,12 @@ unscopeType tloc unscoped t = do (t', m) <- runStateT (traverseDims onDim t) mempty return (t' `addAliases` S.map unAlias, M.elems m) - where onDim p (NamedDim d) + where onDim _ p (NamedDim d) | Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped = if p == PosImmediate || p == PosParam then inst loc $ qualLeaf d else return AnyDim - onDim _ d = return d + onDim _ _ d = return d inst loc d = do prev <- gets $ M.lookup d @@ -1481,12 +1481,6 @@ return $ Index e' idxes' (Info t'', Info retext) loc -checkExp (Unsafe e loc) = do - warn loc $ - "The \"unsafe\" keyword is deprecated and will be removed very soon.\n" ++ - "Remove \"unsafe\" or replace with #[unsafe]." - Unsafe <$> checkExp e <*> pure loc - checkExp (Assert e1 e2 NoInfo loc) = do e1' <- require "being asserted" [Bool] =<< checkExp e1 e2' <- checkExp e2 @@ -1567,11 +1561,12 @@ e_arg <- checkArg e case ftype of Scalar (Arrow as1 m1 t1 (Scalar (Arrow as2 m2 t2 ret))) -> do - (t2', _, argext, _) <- + (t2', ret', argext, _) <- checkApply loc (Just op', 1) (Scalar $ Arrow as2 m2 t2 $ Scalar $ Arrow as1 m1 t1 ret) e_arg return $ OpSectionRight op' (Info ftype) (argExp e_arg) - (Info $ toStruct t1, Info (toStruct t2', argext)) (Info ret) loc + (Info $ toStruct t1, Info (toStruct t2', argext)) + (Info $ addAliases ret (<>aliases ret')) loc _ -> typeError loc mempty $ "Operator section with invalid operator of type" <+> ppr ftype @@ -2286,9 +2281,10 @@ returnType (Scalar (TypeVar als Nonunique t targs)) d arg = Scalar $ TypeVar (als<>arg_als) Unique t targs -- Intentional! where arg_als = aliases $ maskAliases arg d -returnType (Scalar (Arrow _ v t1 t2)) d arg = +returnType (Scalar (Arrow old_als v t1 t2)) d arg = Scalar $ Arrow als v (t1 `setAliases` mempty) (t2 `setAliases` als) - where als = aliases $ maskAliases arg d + -- Make sure to propagate the aliases of an existing closure. + where als = old_als <> aliases (maskAliases arg d) returnType (Scalar (Sum cs)) d arg = Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs @@ -2355,7 +2351,7 @@ let checkCausality what known t loc | (d,dloc):_ <- mapMaybe (unknown constraints known) $ - S.toList $ mustBeExplicit $ toStruct t = + S.toList $ typeDimNames $ toStruct t = Just $ lift $ causality what loc d dloc t | otherwise = Nothing @@ -2377,6 +2373,11 @@ | bad : _ <- mapMaybe (checkParamCausality known) params = bad + onExp known e@(Coerce what _ (_, Info ext) _) = do + modify (S.fromList ext<>) + void $ onExp known what + return e + onExp known e@(LetPat _ bindee_e body_e (_, Info ext) _) = do sequencePoint known bindee_e body_e ext return e @@ -2469,7 +2470,8 @@ inBoundsF x Float32 = not $ isInfinite (realToFrac x :: Float) inBoundsF x Float64 = not $ isInfinite x warnBounds inBounds x ty loc = unless inBounds - $ warn loc $ "Literal " <> show x <> " out of bounds for inferred type " <> pretty ty <> "." + $ typeError loc mempty $ "Literal " <> ppr x <> + " out of bounds for inferred type " <> ppr ty <> "." -- | Type-check a top-level (or module-level) function definition. -- Despite the name, this is also used for checking constant @@ -2776,10 +2778,10 @@ -- the sizes of parameter types, and the sizes of return types. dimUses :: StructType -> (Names, Names, Names) dimUses = execWriter . traverseDims f - where f PosImmediate (NamedDim v) = tell (S.singleton (qualLeaf v), mempty, mempty) - f PosParam (NamedDim v) = tell (mempty, S.singleton (qualLeaf v), mempty) - f PosReturn (NamedDim v) = tell (mempty, mempty, S.singleton (qualLeaf v)) - f _ _ = return () + where f _ PosImmediate (NamedDim v) = tell (S.singleton (qualLeaf v), mempty, mempty) + f _ PosParam (NamedDim v) = tell (mempty, S.singleton (qualLeaf v), mempty) + f _ PosReturn (NamedDim v) = tell (mempty, mempty, S.singleton (qualLeaf v)) + f _ _ _ = return () -- | Find at all type variables in the given type that are covered by -- the constraints, and produce type parameters that close over them. diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -318,9 +318,9 @@ -> TypeBase (DimDecl VName) als -> m (TypeBase (DimDecl VName) als, [VName]) instantiateEmptyArrayDims tloc desc r = runWriterT . traverseDims onDim - where onDim PosImmediate AnyDim = inst - onDim PosParam AnyDim = inst - onDim _ d = return d + where onDim _ PosImmediate AnyDim = inst + onDim _ PosParam AnyDim = inst + onDim _ _ d = return d inst = do dim <- lift $ newDimVar tloc r desc tell [dim] @@ -600,9 +600,17 @@ Just (HasFields required_fields old_usage) -> case tp of Scalar (Record tp_fields) - | all (`M.member` tp_fields) $ M.keys required_fields -> - mapM_ (uncurry $ unify usage) $ M.elems $ - M.intersectionWith (,) required_fields tp_fields + | all (`M.member` tp_fields) $ M.keys required_fields -> do + required_fields' <- mapM normTypeFully required_fields + let bcs' = + breadCrumb + (Matching $ pprName vn <+> + "must be a record with at least the fields:" + indent 2 (ppr (Record required_fields')) + "due to" <+> ppr old_usage <> ".") + bcs + mapM_ (uncurry $ unifyWith onDims usage bcs') $ M.elems $ + M.intersectionWith (,) required_fields tp_fields Scalar (TypeVar _ _ (TypeName [] v) []) | not $ isRigid v constraints -> modifyConstraints $ M.insert v 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 @@ -5,6 +5,7 @@ module Language.Futhark.Warnings ( Warnings , singleWarning + , singleWarning' ) where import Data.Monoid @@ -12,12 +13,13 @@ import Prelude -import Language.Futhark.Core (locStr) +import Language.Futhark.Core (locStr, prettyStacktrace) +import Futhark.Util.Console (inRed) import Futhark.Util.Loc -- | The warnings produced by the compiler. The 'Show' instance -- produces a human-readable description. -newtype Warnings = Warnings [(SrcLoc, String)] deriving (Eq) +newtype Warnings = Warnings [(SrcLoc, [SrcLoc], String)] deriving (Eq) instance Semigroup Warnings where Warnings ws1 <> Warnings ws2 = Warnings $ ws1 <> ws2 @@ -29,13 +31,23 @@ show (Warnings []) = "" show (Warnings ws) = intercalate "\n\n" ws' ++ "\n" - where ws' = map showWarning $ sortOn (off . locOf . fst) ws - off NoLoc = 0 - off (Loc p _) = posCoff p - showWarning (loc, w) = - "Warning at " ++ locStr loc ++ ":\n" ++ + where ws' = map showWarning $ sortOn (rep . wloc) ws + wloc (x, _, _) = locOf x + rep NoLoc = ("", 0) + rep (Loc p _) = (posFile p, posCoff p) + showWarning (loc, [], w) = + inRed ("Warning at " ++ locStr loc ++ ":") ++ "\n" ++ intercalate "\n" (map (" "<>) $ lines w) + showWarning (loc, locs, w) = + inRed ("Warning at\n" ++ + prettyStacktrace 0 (map locStr (loc:locs))) ++ + intercalate "\n" (map (" "<>) $ lines w) -- | A single warning at the given location. singleWarning :: SrcLoc -> String -> Warnings -singleWarning loc problem = Warnings [(loc, problem)] +singleWarning loc = singleWarning' loc [] + +-- | A single warning at the given location, but also with a stack +-- trace (sort of) to the location. +singleWarning' :: SrcLoc -> [SrcLoc] -> String -> Warnings +singleWarning' loc locs problem = Warnings [(loc, locs, problem)] diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -17,6 +17,7 @@ import Futhark.Error import Futhark.Util.Options +import Futhark.Util (maxinum) import qualified Futhark.CLI.Dev as Dev import qualified Futhark.CLI.C as C @@ -24,8 +25,6 @@ import qualified Futhark.CLI.CUDA as CCUDA import qualified Futhark.CLI.Python as Python import qualified Futhark.CLI.PyOpenCL as PyOpenCL -import qualified Futhark.CLI.CSharp as CSharp -import qualified Futhark.CLI.CSOpenCL as CSOpenCL import qualified Futhark.CLI.Test as Test import qualified Futhark.CLI.Bench as Bench import qualified Futhark.CLI.Check as Check @@ -55,9 +54,6 @@ , ("python", (Python.main, "Compile to sequential Python.")) , ("pyopencl", (PyOpenCL.main, "Compile to Python calling PyOpenCL.")) - , ("csharp", (CSharp.main, "Compile to sequential C#.")) - , ("csopencl", (CSOpenCL.main, "Compile to C# calling OpenCL.")) - , ("test", (Test.main, "Test Futhark programs.")) , ("bench", (Bench.main, "Benchmark Futhark programs.")) @@ -79,7 +75,7 @@ [" options...", "Commands:", ""] ++ [ " " <> cmd <> replicate (k - length cmd) ' ' <> desc | (cmd, (_, desc)) <- commands ] - where k = maximum (map (length . fst) commands) + 3 + where k = maxinum (map (length . fst) commands) + 3 -- | Catch all IO exceptions and print a better error message if they -- happen. diff --git a/unittests/Futhark/Analysis/ScalExpTests.hs b/unittests/Futhark/Analysis/ScalExpTests.hs deleted file mode 100644 --- a/unittests/Futhark/Analysis/ScalExpTests.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Analysis.ScalExpTests - ( tests - , parseScalExp - ) -where - -import Test.Tasty - -import Control.Applicative -import Control.Monad.State -import qualified Data.Map as M -import Data.Void -import Text.Megaparsec hiding (token, (<|>), many, State) -import Control.Monad.Combinators.Expr -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -import Futhark.Analysis.ScalExp -import Futhark.IR hiding (constant, SDiv) - -tests :: TestTree -tests = testGroup "ScalExpTests" [] - -parseScalExp :: M.Map String (Int, Type) -> String -> ScalExp -parseScalExp m s = case evalState (runParserT expr ("string: " ++ s) s) (0, m) of - Left err -> error $ show err - Right e -> e - -type ParserState = (Int, M.Map String (Int, Type)) -type Parser = ParsecT Void String (State ParserState) - -newVar :: String -> Type -> Parser Ident -newVar s t = do (x, m) <- lift get - case M.lookup s m of - Just _ -> fail $ "Variable " ++ s ++ " double-declared." - Nothing -> do lift $ put (x+1, M.insert s (x,t) m) - return $ Ident (VName (nameFromString s) x) t - -knownVar :: String -> Parser Ident -knownVar s = do (_, m) <- lift get - case M.lookup s m of - Just (y,t) -> return $ Ident (VName (nameFromString s) y) t - Nothing -> fail $ "Undeclared variable " ++ s - -token :: String -> Parser () -token = L.lexeme space . void . string - -parens :: Parser a -> Parser a -parens = between (token "(") (token ")") - -identifier :: Parser Ident -identifier = do s <- (:) <$> letterChar <*> many alphaNumChar - varDecl s <|> knownVar s - where varDecl s = do - t <- parens $ - (token "int" >> pure (Prim $ IntType Int32)) <|> - (token "float32" >> pure (Prim $ FloatType Float32)) <|> - (token "float64" >> pure (Prim $ FloatType Float64)) <|> - (token "bool" >> pure (Prim Bool)) - newVar s t - -constant :: Parser ScalExp -constant = (token "True" >> pure (Val $ BoolValue True)) <|> - (token "False" >> pure (Val $ BoolValue True)) <|> - (Val . IntValue . Int32Value <$> integer) - where integer = L.lexeme space (L.signed space L.decimal) - -expr :: Parser ScalExp -expr = makeExprParser prim operators - -prim :: Parser ScalExp -prim = parens expr <|> - constant <|> - maxapp <|> - minapp <|> - (scalExpId <$> identifier) - where maxapp = token "max" >> MaxMin False <$> parens (expr `sepBy` comma) - minapp = token "min" >> MaxMin True <$> parens (expr `sepBy` comma) - comma = token "," - scalExpId (Ident name (Prim t)) = Id name t - scalExpId (Ident name t) = error $ - pretty name ++ " is of type " ++ pretty t ++ - " but supposed to be a ScalExp." - -operators :: [[Operator Parser ScalExp]] -operators = [ [Prefix (token "-" >> return SNeg)] - , [InfixL (token "*" >> return STimes)] - , [InfixL (token "pow" >> return SPow)] - , [InfixL (token "/" >> return SDiv)] - , [InfixL (token "+" >> return SPlus)] - , [InfixL (token "-" >> return SMinus)] - , [InfixL (token "<=" >> return leq)] - , [InfixL (token "<" >> return lth)] - , [InfixL (token ">=" >> return (flip leq))] - , [InfixL (token ">" >> return (flip lth))] - , [InfixL (token "&&" >> return SLogAnd)] - , [InfixL (token "||" >> return SLogOr)] - ] - where leq x y = - RelExp LEQ0 $ x `SMinus` y - lth x y = - RelExp LTH0 $ x `SMinus` y diff --git a/unittests/Futhark/IR/Mem/IxFun/Alg.hs b/unittests/Futhark/IR/Mem/IxFun/Alg.hs --- a/unittests/Futhark/IR/Mem/IxFun/Alg.hs +++ b/unittests/Futhark/IR/Mem/IxFun/Alg.hs @@ -9,13 +9,12 @@ , reshape , slice , rebase - , repeat , shape , index ) where -import Prelude hiding (repeat, mod) +import Prelude hiding (mod) import Futhark.IR.Syntax (ShapeChange, DimChange(..), Slice, sliceDims, DimIndex(..), unitSlice) @@ -33,7 +32,6 @@ | Rotate (IxFun num) (Indices num) | Index (IxFun num) (Slice num) | Reshape (IxFun num) (ShapeChange num) - | Repeat (IxFun num) [Shape num] (Shape num) | OffsetIndex (IxFun num) num | Rebase (IxFun num) (IxFun num) deriving (Eq, Show) @@ -47,8 +45,6 @@ ppr (Reshape fun oldshape) = ppr fun <> text "->reshape" <> parens (commasep (map ppr oldshape)) - ppr (Repeat fun outer_shapes inner_shape) = - ppr fun <> text "->repeat" <> parens (commasep (map ppr $ outer_shapes++ [inner_shape])) ppr (OffsetIndex fun i) = ppr fun <> text "->offset_index" <> parens (ppr i) ppr (Rebase new_base fun) = @@ -67,9 +63,6 @@ rotate :: IxFun num -> Indices num -> IxFun num rotate = Rotate -repeat :: IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat = Repeat - slice :: IxFun num -> Slice num -> IxFun num slice = Index @@ -91,9 +84,6 @@ sliceDims how shape (Reshape _ dims) = map newDim dims -shape (Repeat ixfun outer_shapes inner_shape) = - concat (zipWith repeated outer_shapes (shape ixfun)) ++ inner_shape - where repeated outer_ds d = outer_ds ++ [d] shape (OffsetIndex ixfun _) = shape ixfun shape (Rebase _ ixfun) = @@ -118,13 +108,6 @@ index (Reshape fun newshape) is = let new_indices = reshapeIndex (shape fun) (newDims newshape) is in index fun new_indices -index (Repeat fun outer_shapes _) is = - -- Discard those indices that are just repeats. It is intentional - -- that we cut off those indices that correspond to the innermost - -- repeated dimensions. - index fun is' - where flags dims = replicate (length dims) True ++ [False] - is' = map snd $ filter (not . fst) $ zip (concatMap flags outer_shapes) is index (OffsetIndex fun i) is = case shape fun of d : ds -> @@ -144,8 +127,6 @@ slice (rebase new_base ixfun) iis Reshape ixfun new_shape -> reshape (rebase new_base ixfun) new_shape - Repeat ixfun outer_shapes inner_shape -> - repeat (rebase new_base ixfun) outer_shapes inner_shape OffsetIndex ixfun s -> offsetIndex (rebase new_base ixfun) s r@Rebase{} -> diff --git a/unittests/Futhark/IR/Mem/IxFunTests.hs b/unittests/Futhark/IR/Mem/IxFunTests.hs --- a/unittests/Futhark/IR/Mem/IxFunTests.hs +++ b/unittests/Futhark/IR/Mem/IxFunTests.hs @@ -4,7 +4,7 @@ ) where -import Prelude hiding (span, repeat) +import Prelude hiding (span) import qualified Prelude as P import qualified Data.List as DL @@ -83,7 +83,6 @@ , test_slice_iota , test_reshape_slice_iota1 , test_permute_slice_iota - , test_repeat_slice_iota , test_rotate_rotate_permute_slice_iota , test_slice_rotate_permute_slice_iota1 , test_slice_rotate_permute_slice_iota2 @@ -95,12 +94,10 @@ , test_reshape_slice_iota3 , test_complex1 , test_complex2 - , test_complex3 , test_rebase1 , test_rebase2 , test_rebase3 , test_rebase4_5 - , test_rebase6 ] singleton :: TestTree -> [TestTree] @@ -123,10 +120,6 @@ test_permute_slice_iota = singleton $ testCase "permute . slice . iota" $ compareOps $ permute (slice (iota [n, n, n]) slice3) [1, 0] -test_repeat_slice_iota :: [TestTree] -test_repeat_slice_iota = singleton $ testCase "repeat . slice . iota" $ compareOps $ - repeat (slice (iota [n, n, n]) slice3) [[2, 3], [3, 2]] [4, 4] - test_rotate_rotate_permute_slice_iota :: [TestTree] test_rotate_rotate_permute_slice_iota = singleton $ testCase "rotate . rotate . permute . slice . iota" $ compareOps $ @@ -266,28 +259,6 @@ ixfun' = reshape (rotate (slice ixfun slice1) [1, 0, 0, 2]) newdims in ixfun' -test_complex3 :: [TestTree] -test_complex3 = - singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 3" $ compareOps $ - let newdims = [ DimCoercion 1 - , DimCoercion n - , DimNew (n*n) - , DimCoercion 2 - , DimCoercion ((n `P.div` 3) - 2) - ] - slc3 = [ DimFix (n `P.div` 2) - , DimSlice (n-1) (n `P.div` 3) (-1) - , DimSlice (n-1) n (-1) - , DimSlice (n-1) n (-1) - , DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slc3) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] - repeats = [[1],[],[],[2]] - ixfun' = reshape (repeat (rotate (slice ixfun slice1) [1, 0, 0, 2]) repeats []) newdims - in ixfun' - test_rebase1 :: [TestTree] test_rebase1 = singleton $ testCase "rebase 1" $ compareOps $ @@ -347,25 +318,4 @@ ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] in [ testCase "rebase mixed monotonicities" $ compareOps $ rebase ixfn_base ixfn_orig - - , testCase "rebase repetitions and mixed monotonicities 1" $ compareOps $ - let ixfn_orig' = repeat ixfn_orig [[2, 2], [3, 3]] [2, 3] - in rebase ixfn_base ixfn_orig' ] - -test_rebase6 :: [TestTree] -test_rebase6 = - singleton $ testCase "rebase repetitions and mixed monotonicities 2" $ compareOps $ - let n2 = (n-2) `P.div` 3 - n3 = (n-3) `P.div` 2 - slice_base = [ DimFix (n `P.div` 2) - , DimSlice (n-1) n2 (-3) - ] - slice_orig = [ DimSlice (n3-1) n3 (-1) - , DimSlice 0 n2 1 - ] - ixfn_base = permute (repeat (rotate (slice (iota [n, n]) slice_base) [1]) [[], []] [n3]) [1, 0] - ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] - ixfn_orig' = repeat ixfn_orig [[2, 2],[3, 3]] [2, 3] - ixfn_rebase = rebase ixfn_base ixfn_orig' - in ixfn_rebase diff --git a/unittests/Futhark/IR/Mem/IxFunWrapper.hs b/unittests/Futhark/IR/Mem/IxFunWrapper.hs --- a/unittests/Futhark/IR/Mem/IxFunWrapper.hs +++ b/unittests/Futhark/IR/Mem/IxFunWrapper.hs @@ -8,12 +8,9 @@ , reshape , slice , rebase - , repeat ) where -import Prelude hiding (repeat) - import Futhark.Util.IntegralExp import Futhark.IR.Syntax (ShapeChange, Slice) import qualified Futhark.IR.Mem.IxFun as I @@ -37,10 +34,6 @@ rotate :: (Eq num, IntegralExp num) => IxFun num -> Indices num -> IxFun num rotate (l, a) x = (I.rotate l x, IA.rotate a x) - -repeat :: (Eq num, IntegralExp num) => - IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat (l, a) x y = (I.repeat l x y, IA.repeat a x y) reshape :: (Eq num, IntegralExp num) => IxFun num -> ShapeChange num -> IxFun num diff --git a/unittests/Futhark/Optimise/AlgSimplifyTests.hs b/unittests/Futhark/Optimise/AlgSimplifyTests.hs deleted file mode 100644 --- a/unittests/Futhark/Optimise/AlgSimplifyTests.hs +++ /dev/null @@ -1,101 +0,0 @@ -module Futhark.Optimise.AlgSimplifyTests ( tests ) -where - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.List (sort, mapAccumL) -import qualified Data.Map.Strict as M - -import Futhark.IR -import Futhark.Analysis.ScalExp -import Futhark.Analysis.ScalExpTests (parseScalExp) -import Futhark.Analysis.AlgSimplify - -tests :: TestTree -tests = testGroup "AlgSimplifyTests" $ constantFoldTests ++ suffCondTests - -constantFoldTests :: [TestTree] -constantFoldTests = - [ cfoldTest "2+2" "4" - , cfoldTest "2-2" "0" - , cfoldTest "2*3" "6" - , cfoldTest "6/3" "2" - - -- Simple cases over; let's try some variables. - , cfoldTest "0+x" "x" - , cfoldTest "x+x" "2*x" -- Sensitive to operand order - , cfoldTest "x-0" "x" - , cfoldTest "x-x" "0" - , cfoldTest "x/x" "1" - , cfoldTest "x/1" "x" - , cfoldTest "x/x" "1" - ] - where vars = declareVars [("x", int32)] - simplify'' e = simplify' vars e [] - scalExp = parseScalExp vars - - cfoldTest input expected = - testCase ("constant-fold " ++ input) $ - simplify'' input @?= scalExp expected - -suffCondTests :: [TestTree] -suffCondTests = - [ - suffCondTest "5 VarInfo -> VName -lookupVarName s varinfo = case M.lookup s varinfo of - Nothing -> error $ "Unknown variable " ++ s - Just (x,_) -> VName (nameFromString s) x - -declareVars :: VarDecls -> VarInfo -declareVars = M.fromList . snd . mapAccumL declare 0 - where declare i (name, t) = (i+1, (name, (i, Prim t))) - -instantiateRanges :: VarInfo -> RangesRep' -> RangesRep -instantiateRanges varinfo r = - M.fromList $ snd $ mapAccumL fix 0 r - where fix i (name, lower,upper) = - (i+1, - (lookupVarName name varinfo, - (i, fixBound lower, fixBound upper))) - fixBound "" = Nothing - fixBound s = Just $ parseScalExp varinfo s - -simplify' :: VarInfo -> String -> RangesRep' -> ScalExp -simplify' varinfo s r = simplify e r' - where e = parseScalExp varinfo s - r' = instantiateRanges varinfo r - -mkSuffConds' :: VarInfo -> String -> RangesRep' -> [[ScalExp]] -mkSuffConds' varinfo s r = - case mkSuffConds e r' of - Left _ -> [[e]] - Right sc -> sc - where e = simplify (parseScalExp varinfo s) r' - r' = instantiateRanges varinfo r diff --git a/unittests/futhark_tests.hs b/unittests/futhark_tests.hs --- a/unittests/futhark_tests.hs +++ b/unittests/futhark_tests.hs @@ -5,10 +5,8 @@ import qualified Futhark.IR.Syntax.CoreTests import qualified Futhark.IR.PropTests import qualified Futhark.IR.Mem.IxFunTests -import qualified Futhark.Optimise.AlgSimplifyTests import qualified Futhark.Pkg.SolveTests import qualified Futhark.IR.PrimitiveTests -import qualified Futhark.Analysis.ScalExpTests import Test.Tasty @@ -18,12 +16,10 @@ [ Language.Futhark.SyntaxTests.tests , Futhark.BenchTests.tests , Futhark.IR.PropTests.tests - , Futhark.Optimise.AlgSimplifyTests.tests , Futhark.IR.Syntax.CoreTests.tests , Futhark.Pkg.SolveTests.tests , Futhark.IR.Mem.IxFunTests.tests , Futhark.IR.PrimitiveTests.tests - , Futhark.Analysis.ScalExpTests.tests ] main :: IO ()