futhark 0.15.3 → 0.15.4
raw patch · 105 files changed
+1835/−1490 lines, 105 filesdep +cmark-gfmdep −http-clientdep −http-client-tlsdep −http-conduit
Dependencies added: cmark-gfm
Dependencies removed: http-client, http-client-tls, http-conduit, markdown
Files
- docs/installation.rst +17/−7
- docs/man/futhark-autotune.rst +8/−0
- docs/man/futhark-bench.rst +5/−0
- docs/man/futhark-pkg.rst +3/−0
- docs/man/futhark-pyopencl.rst +4/−4
- docs/man/futhark-python.rst +1/−1
- docs/usage.rst +5/−0
- futhark.cabal +2/−5
- prelude/soacs.fut +1/−1
- rts/c/cuda.h +4/−4
- rts/c/free_list.h +9/−3
- rts/c/opencl.h +4/−4
- rts/c/panic.h +1/−1
- rts/c/values.h +13/−13
- src/Futhark/Actions.hs +3/−7
- src/Futhark/Analysis/Alias.hs +3/−2
- src/Futhark/Analysis/CallGraph.hs +55/−22
- src/Futhark/Analysis/Metrics.hs +4/−1
- src/Futhark/Analysis/PrimExp/Convert.hs +1/−1
- src/Futhark/Analysis/Range.hs +2/−1
- src/Futhark/Analysis/Rephrase.hs +4/−1
- src/Futhark/Analysis/SymbolTable.hs +7/−0
- src/Futhark/Bench.hs +5/−0
- src/Futhark/CLI/Autotune.hs +114/−92
- src/Futhark/CLI/Bench.hs +6/−1
- src/Futhark/CLI/C.hs +1/−3
- src/Futhark/CLI/CSOpenCL.hs +2/−4
- src/Futhark/CLI/CSharp.hs +1/−3
- src/Futhark/CLI/CUDA.hs +1/−3
- src/Futhark/CLI/Dev.hs +1/−2
- src/Futhark/CLI/OpenCL.hs +1/−3
- src/Futhark/CLI/Pkg.hs +9/−8
- src/Futhark/CLI/PyOpenCL.hs +1/−4
- src/Futhark/CLI/Python.hs +1/−4
- src/Futhark/CLI/Test.hs +1/−4
- src/Futhark/CodeGen/Backends/CCUDA.hs +9/−12
- src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +14/−5
- src/Futhark/CodeGen/Backends/COpenCL.hs +16/−19
- src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +19/−25
- src/Futhark/CodeGen/Backends/CSOpenCL.hs +49/−50
- src/Futhark/CodeGen/Backends/GenericC.hs +114/−64
- src/Futhark/CodeGen/Backends/GenericC/Options.hs +2/−2
- src/Futhark/CodeGen/Backends/GenericCSharp.hs +118/−101
- src/Futhark/CodeGen/Backends/GenericPython.hs +94/−79
- src/Futhark/CodeGen/Backends/PyOpenCL.hs +120/−127
- src/Futhark/CodeGen/Backends/SequentialC.hs +5/−3
- src/Futhark/CodeGen/Backends/SequentialCSharp.hs +12/−13
- src/Futhark/CodeGen/Backends/SequentialPython.hs +7/−8
- src/Futhark/CodeGen/ImpCode.hs +30/−1
- src/Futhark/CodeGen/ImpCode/Kernels.hs +1/−1
- src/Futhark/CodeGen/ImpCode/OpenCL.hs +1/−1
- src/Futhark/CodeGen/ImpCode/Sequential.hs +1/−1
- src/Futhark/CodeGen/ImpGen.hs +96/−60
- src/Futhark/CodeGen/ImpGen/CUDA.hs +2/−4
- src/Futhark/CodeGen/ImpGen/Kernels.hs +2/−2
- src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +2/−2
- src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +11/−5
- src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +28/−19
- src/Futhark/CodeGen/ImpGen/OpenCL.hs +2/−3
- src/Futhark/CodeGen/ImpGen/Sequential.hs +2/−3
- src/Futhark/CodeGen/SetDefaultSpace.hs +8/−5
- src/Futhark/Doc/Generator.hs +5/−3
- src/Futhark/Error.hs +12/−11
- src/Futhark/Internalise.hs +86/−144
- src/Futhark/Internalise/Bindings.hs +11/−13
- src/Futhark/Internalise/Monad.hs +60/−45
- src/Futhark/Internalise/TypesValues.hs +13/−31
- src/Futhark/Optimise/CSE.hs +34/−14
- src/Futhark/Optimise/DoubleBuffer.hs +6/−7
- src/Futhark/Optimise/Fusion.hs +40/−29
- src/Futhark/Optimise/InPlaceLowering.hs +13/−4
- src/Futhark/Optimise/InliningDeadFun.hs +98/−137
- src/Futhark/Optimise/Simplify.hs +52/−18
- src/Futhark/Optimise/Simplify/Engine.hs +25/−16
- src/Futhark/Optimise/Simplify/Rules.hs +9/−0
- src/Futhark/Optimise/Sink.hs +11/−9
- src/Futhark/Optimise/TileLoops.hs +2/−1
- src/Futhark/Optimise/Unstream.hs +9/−10
- src/Futhark/Pass.hs +39/−20
- src/Futhark/Pass/ExpandAllocations.hs +13/−8
- src/Futhark/Pass/ExplicitAllocations.hs +7/−4
- src/Futhark/Pass/ExtractKernels.hs +12/−5
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +2/−2
- src/Futhark/Pass/FirstOrderTransform.hs +4/−3
- src/Futhark/Pass/KernelBabysitting.hs +10/−11
- src/Futhark/Passes.hs +0/−3
- src/Futhark/Pipeline.hs +4/−6
- src/Futhark/Pkg/Info.hs +48/−38
- src/Futhark/Representation/AST/Attributes.hs +2/−2
- src/Futhark/Representation/AST/Attributes/Names.hs +11/−0
- src/Futhark/Representation/AST/Pretty.hs +8/−8
- src/Futhark/Representation/AST/Syntax.hs +12/−8
- src/Futhark/Representation/Aliases.hs +4/−8
- src/Futhark/Representation/ExplicitMemory/Simplify.hs +5/−2
- src/Futhark/Representation/Ranges.hs +5/−0
- src/Futhark/Representation/SOACS/Simplify.hs +12/−3
- src/Futhark/Transform/CopyPropagate.hs +21/−7
- src/Futhark/Transform/FirstOrderTransform.hs +12/−3
- src/Futhark/Transform/Rename.hs +4/−11
- src/Futhark/TypeCheck.hs +16/−14
- src/Futhark/Util/Pretty.hs +15/−1
- src/Futhark/Util/Table.hs +2/−3
- src/Language/Futhark/TypeChecker.hs +2/−2
- src/Language/Futhark/TypeChecker/Monad.hs +1/−1
- src/futhark.hs +13/−1
docs/installation.rst view
@@ -16,15 +16,23 @@ Dependencies ------------ -On non-Windows, you will need to have the ``gmp`` and ``tinfo``-libraries installed. These are pretty common, so you may already have-them. On Debian-like systems (e.g. Ubuntu), use::+The Linux binaries we distribute are statically linked and should not+require any special libraries installed system-wide. +When building from source on Linux and macOS, you will need to have+the ``gmp`` and ``tinfo`` libraries installed. These are pretty+common, so you may already have them. On Debian-like systems+(e.g. Ubuntu), use::+ sudo apt install libtinfo-dev libgmp-dev If you install Futhark via a package manager (e.g. Homebrew, Nix, or-AUR), you shouldn't need to worry about this.+AUR), you shouldn't need to worry about any of this. +Actually *running* the output of the Futhark compiler may require+additional dependencies, for example an OpenCL library and GPU driver.+See the documentation for the respective compiler backends.+ Compiling from source --------------------- @@ -74,11 +82,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~~ You can also compile Futhark with ``cabal``. If so, you must install-an appropriate version of GHC and ``cabal`` yourself, for example-through your favourite package manager. On Linux, you can always use-`ghcup <https://gitlab.haskell.org/haskell/ghcup>`_. Then clone the+an appropriate version of GHC (usually the newest) and ``cabal``+yourself, for example through your favourite package manager. On+Linux, you can always use `ghcup+<https://gitlab.haskell.org/haskell/ghcup>`_. Then clone the repository as listed above and run:: + $ cabal update $ cabal build To install the Futhark binaries to a specific location, for example
docs/man/futhark-autotune.rst view
@@ -59,6 +59,14 @@ Change the extension used for tuning files (``.tuning`` by default). +--timeout=seconds++ Initial tuning timeout for each dataset in seconds. After running the intitial+ tuning run on each dataset, the timeout is based on the run time of that+ initial tuning. Defaults to 60.++ A negative timeout means to wait indefinitely.+ SEE ALSO ========
docs/man/futhark-bench.rst view
@@ -108,6 +108,11 @@ A negative timeout means to wait indefinitely. +-v, --verbose++ Print verbose information about what the benchmark is doing. Pass+ multiple times to increase the amount of information printed.+ --tuning=EXTENSION For each program being run, look for a tuning file with this
docs/man/futhark-pkg.rst view
@@ -53,6 +53,9 @@ Most commands take a ``-v``/``--verbose`` option that makes ``futhark pkg`` write running diagnostics to stderr. +Network requests (exclusively HTTP GETs) are done via ``curl``, which+must be available on the ``PATH``.+ COMMANDS ========
docs/man/futhark-pyopencl.rst view
@@ -15,10 +15,10 @@ =========== ``futhark pyopencl`` translates a Futhark program to Python code-invoking OpenCL kernels. By default, the program uses the first-device of the first OpenCL platform - this can be changed by passing-``-p`` and ``-d`` options to the generated program (not to-``futhark pyopencl`` itself).+invoking OpenCL kernels, which depends on Numpy and PyOpenCL. By+default, the program uses the first device of the first OpenCL+platform - this can be changed by passing ``-p`` and ``-d`` options to+the generated program (not to ``futhark pyopencl`` itself). The resulting program will otherwise behave exactly as one compiled with ``futhark py``. While the sequential host-level code is pure
docs/man/futhark-python.rst view
@@ -15,7 +15,7 @@ =========== ``futhark python`` translates a Futhark program to sequential Python-code.+code, which depends on Numpy. The resulting program will read the arguments to the ``main`` function from standard input and print its return value on standard output.
docs/usage.rst view
@@ -340,6 +340,11 @@ struct futhark_context *futhark_context_new(struct futhark_context_config *cfg); +Context creation may fail. Immediately after+``futhark_context_new()``, call ``futhark_context_get_error()`` (see+below), which will return a non-NULL error string if context creation+failed.+ Memory management is entirely manual. Deallocation functions are provided for all types defined in the header file. Everything returned by an entry point must be manually deallocated.
futhark.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: futhark-version: 0.15.3+version: 0.15.4 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to efficient parallel code. It is a statically typed, data-parallel,@@ -267,12 +267,9 @@ , free >=4.12.4 , gitrev >=1.2.0 , haskeline- , http-client >=0.5.7.0- , http-client-tls >=0.3.5.1- , http-conduit >=2.2.4 , language-c-quote >=0.12 , mainland-pretty >=0.6.1- , markdown >=0.1.16+ , cmark-gfm >=0.2.1 , megaparsec >=8.0.0 , mtl >=2.2.1 , neat-interpolation >=0.3
prelude/soacs.fut view
@@ -106,7 +106,7 @@ -- | `reduce_by_index dest f ne is as` returns `dest`, but with each -- element given by the indices of `is` updated by applying `f` to the -- current value in `dest` and the corresponding value in `as`. The--- `ne` value must be a neutral element for `op`. If `is` has+-- `ne` value must be a neutral element for `f`. If `is` has -- duplicates, `f` may be applied multiple times, and hence must be -- associative and commutative. Out-of-bounds indices in `is` are -- ignored.
rts/c/cuda.h view
@@ -9,7 +9,7 @@ const char *err_str; cuGetErrorString(res, &err_str); if (err_str == NULL) { err_str = "Unknown"; }- panic(-1, "%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n",+ futhark_panic(-1, "%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", file, line, call, res, err_str); } }@@ -18,7 +18,7 @@ const char *file, int line) { if (res != NVRTC_SUCCESS) { const char *err_str = nvrtcGetErrorString(res);- panic(-1, "%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n",+ futhark_panic(-1, "%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", file, line, call, res, err_str); } }@@ -231,7 +231,7 @@ } if (chosen == -1) {- panic(-1, "Unsupported compute capability %d.%d\n", major, minor);+ futhark_panic(-1, "Unsupported compute capability %d.%d\n", major, minor); } if (x[chosen].major != major || x[chosen].minor != minor) {@@ -458,7 +458,7 @@ CUDA_SUCCEED(cuInit(0)); if (cuda_device_setup(ctx) != 0) {- panic(-1, "No suitable CUDA device found.\n");+ futhark_panic(-1, "No suitable CUDA device found.\n"); } CUDA_SUCCEED(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev));
rts/c/free_list.h view
@@ -34,9 +34,15 @@ p++; } }- // Now p == l->used.- l->entries = realloc(l->entries, l->used * sizeof(struct free_list_entry));- l->capacity = l->used;++ // Now p is the number of used elements. We don't want it to go+ // less than the default capacity (although in practice it's OK as+ // long as it doesn't become 1).+ if (p < 30) {+ p = 30;+ }+ l->entries = realloc(l->entries, p * sizeof(struct free_list_entry));+ l->capacity = p; } static void free_list_destroy(struct free_list *l) {
rts/c/opencl.h view
@@ -222,7 +222,7 @@ const char *file, int line) { if (ret != CL_SUCCESS) {- panic(-1, "%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n",+ futhark_panic(-1, "%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n", file, line, call, ret, opencl_error_string(ret)); } }@@ -444,7 +444,7 @@ } } - panic(1, "Could not find acceptable OpenCL device.\n");+ futhark_panic(1, "Could not find acceptable OpenCL device.\n"); exit(1); // Never reached } @@ -535,7 +535,7 @@ OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE, sizeof(cl_uint), &supported, NULL)); if (!supported) {- panic(1, "Program uses double-precision floats, but this is not supported on the chosen device: %s\n",+ futhark_panic(1, "Program uses double-precision floats, but this is not supported on the chosen device: %s\n", device_option.device_name); } }@@ -627,7 +627,7 @@ if (ctx->cfg.load_program_from != NULL) { fut_opencl_src = slurp_file(ctx->cfg.load_program_from, NULL); assert(fut_opencl_src != NULL);- } else if (ctx->cfg.load_binary_from == NULL) {+ } else { // Construct the OpenCL source concatenating all the fragments. for (const char **src = srcs; src && *src; src++) { src_size += strlen(*src);
rts/c/panic.h view
@@ -4,7 +4,7 @@ static const char *fut_progname; -static void panic(int eval, const char *fmt, ...)+static void futhark_panic(int eval, const char *fmt, ...) { va_list ap;
rts/c/values.h view
@@ -536,10 +536,10 @@ int8_t bin_version; int ret = read_byte(&bin_version); - if (ret != 0) { panic(1, "binary-input: could not read version.\n"); }+ if (ret != 0) { futhark_panic(1, "binary-input: could not read version.\n"); } if (bin_version != BINARY_FORMAT_VERSION) {- panic(1, "binary-input: File uses version %i, but I only understand version %i.\n",+ futhark_panic(1, "binary-input: File uses version %i, but I only understand version %i.\n", bin_version, BINARY_FORMAT_VERSION); } @@ -553,7 +553,7 @@ char read_binname[4]; int num_matched = scanf("%4c", read_binname);- if (num_matched != 1) { panic(1, "binary-input: Couldn't read element type.\n"); }+ if (num_matched != 1) { futhark_panic(1, "binary-input: Couldn't read element type.\n"); } const struct primtype_info_t **type = primtypes; @@ -564,23 +564,23 @@ return *type; } }- panic(1, "binary-input: Did not recognize the type '%s'.\n", read_binname);+ futhark_panic(1, "binary-input: Did not recognize the type '%s'.\n", read_binname); return NULL; } static void read_bin_ensure_scalar(const struct primtype_info_t *expected_type) { int8_t bin_dims; int ret = read_byte(&bin_dims);- if (ret != 0) { panic(1, "binary-input: Couldn't get dims.\n"); }+ if (ret != 0) { futhark_panic(1, "binary-input: Couldn't get dims.\n"); } if (bin_dims != 0) {- panic(1, "binary-input: Expected scalar (0 dimensions), but got array with %i dimensions.\n",+ futhark_panic(1, "binary-input: Expected scalar (0 dimensions), but got array with %i dimensions.\n", bin_dims); } const struct primtype_info_t *bin_type = read_bin_read_type_enum(); if (bin_type != expected_type) {- panic(1, "binary-input: Expected scalar of type %s but got scalar of type %s.\n",+ futhark_panic(1, "binary-input: Expected scalar of type %s but got scalar of type %s.\n", expected_type->type_name, bin_type->type_name); }@@ -593,16 +593,16 @@ int8_t bin_dims; ret = read_byte(&bin_dims);- if (ret != 0) { panic(1, "binary-input: Couldn't get dims.\n"); }+ if (ret != 0) { futhark_panic(1, "binary-input: Couldn't get dims.\n"); } if (bin_dims != dims) {- panic(1, "binary-input: Expected %i dimensions, but got array with %i dimensions.\n",+ futhark_panic(1, "binary-input: Expected %i dimensions, but got array with %i dimensions.\n", dims, bin_dims); } const struct primtype_info_t *bin_primtype = read_bin_read_type_enum(); if (expected_type != bin_primtype) {- panic(1, "binary-input: Expected %iD-array with element type '%s' but got %iD-array with element type '%s'.\n",+ futhark_panic(1, "binary-input: Expected %iD-array with element type '%s' but got %iD-array with element type '%s'.\n", dims, expected_type->type_name, dims, bin_primtype->type_name); } @@ -611,7 +611,7 @@ int64_t bin_shape; ret = fread(&bin_shape, sizeof(bin_shape), 1, stdin); if (ret != 1) {- panic(1, "binary-input: Couldn't read size for dimension %i of array.\n", i);+ futhark_panic(1, "binary-input: Couldn't read size for dimension %i of array.\n", i); } if (IS_BIG_ENDIAN) { flip_bytes(sizeof(bin_shape), (unsigned char*) &bin_shape);@@ -623,14 +623,14 @@ int64_t elem_size = expected_type->size; void* tmp = realloc(*data, (size_t)(elem_count * elem_size)); if (tmp == NULL) {- panic(1, "binary-input: Failed to allocate array of size %i.\n",+ futhark_panic(1, "binary-input: Failed to allocate array of size %i.\n", elem_count * elem_size); } *data = tmp; int64_t num_elems_read = (int64_t)fread(*data, (size_t)elem_size, (size_t)elem_count, stdin); if (num_elems_read != elem_count) {- panic(1, "binary-input: tried to read %i elements of an array, but only got %i elements.\n",+ futhark_panic(1, "binary-input: tried to read %i elements of an array, but only got %i elements.\n", elem_count, num_elems_read); }
src/Futhark/Actions.hs view
@@ -8,6 +8,7 @@ ) where +import Control.Monad import Control.Monad.IO.Class import Futhark.Pipeline@@ -20,7 +21,6 @@ import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import Futhark.Representation.AST.Attributes.Ranges (CanBeRanged) import Futhark.Analysis.Metrics-import Futhark.Util.Pretty (prettyText) printAction :: (Attributes lore, CanBeAliased (Op lore)) => Action lore printAction =@@ -47,16 +47,12 @@ impCodeGenAction = Action { actionName = "Compile imperative" , actionDescription = "Translate program into imperative IL and write it on standard output."- , actionProcedure = \prog ->- either (`internalError` prettyText prog) (liftIO . putStrLn . pretty) =<<- ImpGenSequential.compileProg prog+ , actionProcedure = liftIO . putStrLn . pretty <=< ImpGenSequential.compileProg } kernelImpCodeGenAction :: Action ExplicitMemory kernelImpCodeGenAction = Action { actionName = "Compile imperative kernels" , actionDescription = "Translate program into imperative IL with kernels and write it on standard output."- , actionProcedure = \prog ->- either (`internalError` prettyText prog) (liftIO . putStrLn . pretty) =<<- ImpGenKernels.compileProg prog+ , actionProcedure = liftIO . putStrLn . pretty <=< ImpGenKernels.compileProg }
src/Futhark/Analysis/Alias.hs view
@@ -12,7 +12,7 @@ -- * Ad-hoc utilities , AliasTable , analyseFun- , analyseStm+ , analyseStms , analyseExp , analyseBody , analyseLambda@@ -28,7 +28,8 @@ -- | Perform alias analysis on a Futhark program. aliasAnalysis :: (Attributes lore, CanBeAliased (Op lore)) => Prog lore -> Prog (Aliases lore)-aliasAnalysis = Prog . map analyseFun . progFuns+aliasAnalysis (Prog consts funs) =+ Prog (fst (analyseStms mempty consts)) (map analyseFun funs) analyseFun :: (Attributes lore, CanBeAliased (Op lore)) => FunDef lore -> FunDef (Aliases lore)
src/Futhark/Analysis/CallGraph.hs view
@@ -3,12 +3,17 @@ module Futhark.Analysis.CallGraph ( CallGraph , buildCallGraph+ , isFunInCallGraph+ , calls+ , calledByConsts+ , allCalledBy ) where import Control.Monad.Writer.Strict import qualified Data.Map.Strict as M-import Data.Maybe (isJust)+import qualified Data.Set as S+import Data.Maybe (fromMaybe) import Data.List (foldl') import Futhark.Representation.SOACS@@ -19,44 +24,72 @@ buildFunctionTable = foldl expand M.empty . progFuns where expand ftab f = M.insert (funDefName f) f ftab --- | The call graph is just a mapping from a function name, i.e., the+type FunGraph = M.Map Name (S.Set Name)++-- | The call graph is a mapping from a function name, i.e., the -- caller, to a set of the names of functions called *directly* (not -- transitively!) by the function.-type CallGraph = M.Map Name (M.Map Name ConstFun)+--+-- We keep track separately of the functions called by constants.+data CallGraph = CallGraph { calledByFuns :: M.Map Name (S.Set Name)+ , calledInConsts :: S.Set Name+ } +-- | Is the given function known to the call graph?+isFunInCallGraph :: Name -> CallGraph -> Bool+isFunInCallGraph f = M.member f . calledByFuns++-- | Does the first function call the second?+calls :: Name -> Name -> CallGraph -> Bool+calls caller callee =+ maybe False (S.member callee) . M.lookup caller . calledByFuns++-- | Is the function called in any of the constants?+calledByConsts :: Name -> CallGraph -> Bool+calledByConsts f = S.member f . calledInConsts++-- | All functions called by this function.+allCalledBy :: Name -> CallGraph -> S.Set Name+allCalledBy f = fromMaybe mempty . M.lookup f . calledByFuns+ -- | @buildCallGraph prog@ build the program's call graph. buildCallGraph :: Prog SOACS -> CallGraph-buildCallGraph prog = foldl' (buildCGfun ftable) M.empty entry_points- where entry_points = map funDefName $ filter (isJust . funDefEntryPoint) $- progFuns prog+buildCallGraph prog =+ CallGraph fg $ buildFGStms $ progConsts prog+ where fg = foldl' (buildFGfun ftable) M.empty entry_points++ entry_points = map funDefName $ progFuns prog ftable = buildFunctionTable prog --- | @buildCallGraph ftable cg fname@ updates @cg@ with the+-- | @buildCallGraph ftable fg fname@ updates @fg@ with the -- contributions of function @fname@.-buildCGfun :: FunctionTable -> CallGraph -> Name -> CallGraph-buildCGfun ftable cg fname =+buildFGfun :: FunctionTable -> FunGraph -> Name -> FunGraph+buildFGfun ftable fg fname = -- Check if function is a non-builtin that we have not already -- processed. case M.lookup fname ftable of- Just f | Nothing <- M.lookup fname cg -> do- let callees = buildCGbody $ funDefBody f- cg' = M.insert fname callees cg+ Just f | Nothing <- M.lookup fname fg -> do+ let callees = buildFGBody $ funDefBody f+ fg' = M.insert fname callees fg -- recursively build the callees- foldl' (buildCGfun ftable) cg' $ M.keys callees- _ -> cg+ foldl' (buildFGfun ftable) fg' callees+ _ -> fg -buildCGbody :: Body -> M.Map Name ConstFun-buildCGbody = mconcat . map (buildCGexp . stmExp) . stmsToList . bodyStms+buildFGStms :: Stms SOACS -> S.Set Name+buildFGStms = mconcat . map (buildFGexp . stmExp) . stmsToList -buildCGexp :: Exp -> M.Map Name ConstFun-buildCGexp (Apply fname _ _ (constf, _, _, _)) = M.singleton fname constf-buildCGexp (Op op) = execWriter $ mapSOACM folder op+buildFGBody :: Body -> S.Set Name+buildFGBody = buildFGStms . bodyStms++buildFGexp :: Exp -> S.Set Name+buildFGexp (Apply fname _ _ _) = S.singleton fname+buildFGexp (Op op) = execWriter $ mapSOACM folder op where folder = identitySOACMapper {- mapOnSOACLambda = \lam -> do tell $ buildCGbody $ lambdaBody lam+ mapOnSOACLambda = \lam -> do tell $ buildFGBody $ lambdaBody lam return lam }-buildCGexp e = execWriter $ mapExpM folder e+buildFGexp e = execWriter $ mapExpM folder e where folder = identityMapper {- mapOnBody = \_ body -> do tell $ buildCGbody body+ mapOnBody = \_ body -> do tell $ buildFGBody body return body }
src/Futhark/Analysis/Metrics.hs view
@@ -73,7 +73,10 @@ addWhat' (ctx, k) = (what : ctx, k) progMetrics :: OpMetrics (Op lore) => Prog lore -> AstMetrics-progMetrics = actualMetrics . execWriter . runMetricsM . mapM_ funDefMetrics . progFuns+progMetrics prog =+ actualMetrics $ execWriter $ runMetricsM $ do+ mapM_ funDefMetrics $ progFuns prog+ mapM_ bindingMetrics $ progConsts prog funDefMetrics :: OpMetrics (Op lore) => FunDef lore -> MetricsM () funDefMetrics = bodyMetrics . funDefBody
src/Futhark/Analysis/PrimExp/Convert.hs view
@@ -45,7 +45,7 @@ return $ BasicOp $ SubExp $ Constant v primExpToExp f (FunExp h args t) = Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*>- pure (NotConstFun, Safe, noLoc, [])+ pure (Safe, noLoc, []) where args' = zip <$> mapM (primExpToSubExp "apply_arg" f) args <*> pure (repeat Observe) primExpToExp f (LeafExp v _) = f v
src/Futhark/Analysis/Range.hs view
@@ -25,7 +25,8 @@ -- program with embedded range annotations. rangeAnalysis :: (Attributes lore, CanBeRanged (Op lore)) => Prog lore -> Prog (Ranges lore)-rangeAnalysis = Prog . map analyseFun . progFuns+rangeAnalysis (Prog consts funs) =+ Prog (runRangeM $ mapM analyseStm consts) (map analyseFun funs) -- Implementation
src/Futhark/Analysis/Rephrase.hs view
@@ -28,7 +28,10 @@ } rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to)-rephraseProg rephraser = fmap Prog . mapM (rephraseFunDef rephraser) . progFuns+rephraseProg rephraser (Prog consts funs) =+ Prog+ <$> mapM (rephraseStm rephraser) consts+ <*> mapM (rephraseFunDef rephraser) funs rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) rephraseFunDef rephraser fundec = do
src/Futhark/Analysis/SymbolTable.hs view
@@ -35,6 +35,7 @@ , IndexOp(..) -- * Insertion , insertStm+ , insertStms , insertFParams , insertLParam , insertArrayLParam@@ -496,6 +497,12 @@ FParam entry { fparamAliases = oneName (patElemName pe) <> fparamAliases entry } update e = e++insertStms :: (IndexOp (Op lore), Ranged lore, Aliases.Aliased lore) =>+ Stms lore+ -> SymbolTable lore+ -> SymbolTable lore+insertStms stms vtable = foldl' (flip insertStm) vtable $ stmsToList stms expandAliases :: Names -> SymbolTable lore -> Names expandAliases names vtable = names <> aliasesOfAliases
src/Futhark/Bench.hs view
@@ -156,6 +156,7 @@ , runRuns :: Int , runExtraOptions :: [String] , runTimeout :: Int+ , runVerbose :: Int } -- | Run the benchmark program on the indicated dataset.@@ -185,6 +186,10 @@ let (to_run, to_run_args) | null $ runRunner opts = ("." </> binaryName program, options) | otherwise = (runRunner opts, binaryName program : options)++ when (runVerbose opts > 1) $+ putStrLn $ unwords ["Running executable", show to_run,+ "with arguments", show to_run_args] run_res <- timeout (runTimeout opts * 1000000) $
src/Futhark/CLI/Autotune.hs view
@@ -4,13 +4,14 @@ import Control.Monad import qualified Data.ByteString.Char8 as SBS-import Data.Time.Clock.POSIX+import Data.Function (on) import Data.Tree-import Data.List (intersect, isPrefixOf, foldl', sort, sortOn)+import Data.List (intersect, isPrefixOf, sort, sortOn, elemIndex, minimumBy) import Data.Maybe import Text.Read (readMaybe) import Text.Regex.TDFA import qualified Data.Text as T+import qualified Data.Set as S import System.Environment (getExecutablePath) import System.Exit@@ -29,11 +30,12 @@ , optTuning :: Maybe String , optExtraOptions :: [String] , optVerbose :: Int+ , optTimeout :: Int } initialAutotuneOptions :: AutotuneOptions initialAutotuneOptions =- AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0+ AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0 60 compileOptions :: AutotuneOptions -> IO CompileOptions compileOptions opts = do@@ -49,6 +51,7 @@ , runRuns = optRuns opts , runExtraOptions = "-L" : map opt path ++ optExtraOptions opts , runTimeout = timeout_s+ , runVerbose = optVerbose opts } where opt (name, val) = "--size=" ++ name ++ "=" ++ show val @@ -68,10 +71,7 @@ return (thresh, val') -data RunPurpose = RunSample -- ^ Only a single run.- | RunBenchmark -- ^ As many runs as needed.--type RunDataset = Path -> RunPurpose -> IO (Either String ([(String, Int)], Double))+type RunDataset = Int -> Path -> IO (Either String ([(String, Int)], Int)) type DatasetName = String @@ -106,41 +106,24 @@ _ -> Nothing - -- We wish to let datasets run for the untuned time + 20% + 1 second.- let timeout elapsed = ceiling (elapsed * 1.2) + 1- fmap concat $ forM truns $ \ios -> forM (mapMaybe (runnableDataset $ iosEntryPoint ios) (iosTestRuns ios)) $- \(dataset, do_run) -> do- bef <- toRational <$> getPOSIXTime- res <- do_run 60000 [] RunBenchmark- aft <- toRational <$> getPOSIXTime- case res of Left err -> do- putStrLn $ "Error when running " ++ prog ++ ":"- putStrLn err- exitFailure- Right _ -> do- let t = timeout $ aft - bef- putStrLn $ "Calculated timeout for " ++ dataset ++- " : " ++ show t ++ "s"- return (dataset, do_run t, iosEntryPoint ios)-- where run entry_point trun expected timeout path purpose = do- let opts' = case purpose of RunSample -> opts { optRuns = 1 }- RunBenchmark -> opts+ \(dataset, do_run) ->+ return (dataset, do_run, iosEntryPoint ios) - averageRuntime (runres, errout) =+ where run entry_point trun expected timeout path = do+ let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int)+ bestRuntime (runres, errout) = (comparisons (T.unpack errout),- fromIntegral (sum (map runMicroseconds runres)) /- fromIntegral (optRuns opts))+ minimum $ map runMicroseconds runres) - ropts = runOptions path timeout opts'+ ropts = runOptions path timeout opts when (optVerbose opts > 1) $ putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts) - either (Left . T.unpack) (Right . averageRuntime) <$>+ either (Left . T.unpack) (Right . bestRuntime) <$> benchmarkDataset ropts prog entry_point (runInput trun) expected (testRunReferenceOutput prog entry_point trun)@@ -207,81 +190,111 @@ --- Doing the atual tuning -intersectRanges :: [(Int, Int)] -> (Int, Int)-intersectRanges = foldl' f (thresholdMin, thresholdMax)- where f (xmin, xmax) (ymin, ymax) =- -- XXX: what happens when the intersection is empty?- (xmin `max` ymin,- xmax `min` ymax)- tuneThreshold :: AutotuneOptions -> [(DatasetName, RunDataset, T.Text)] -> Path -> (String, Path) -> IO Path-tuneThreshold opts datasets already_tuned (v, v_path) = do- ranges <-- forM datasets $ \(dataset_name, run, entry_point) ->+tuneThreshold opts datasets already_tuned (v, _v_path) = do+ (_, threshold) <-+ foldM tuneDataset (thresholdMin, thresholdMax) datasets+ return $ (v, threshold) : already_tuned - if not $ isPrefixOf (T.unpack entry_point ++ ".") v then do+ where+ tuneDataset :: (Int, Int) -> (DatasetName, RunDataset, T.Text) -> IO (Int, Int)+ tuneDataset (tMin, tMax) (dataset_name, run, entry_point) =+ if not $ isPrefixOf (T.unpack entry_point ++ ".") v then do when (optVerbose opts > 0) $ putStrLn $ unwords [v, "is irrelevant for", T.unpack entry_point]- return (thresholdMin, thresholdMax)- else do+ return (tMin, tMax)+ else do - putStrLn $ unwords ["Tuning", v, "on entry point", T.unpack entry_point,- "and dataset", dataset_name]+ putStrLn $ unwords ["Tuning", v, "on entry point", T.unpack entry_point,+ "and dataset", dataset_name] - sample_run <- run path RunSample+ sample_run <- run (optTimeout opts) ((v, tMax) : already_tuned) - case sample_run of- Left err -> do- -- If the sampling run fails, we treat it as zero information.- -- One of our ancestor thresholds will have be set such that- -- this path is never taken.- when (optVerbose opts > 0) $ putStrLn $- "Sampling run failed:\n" ++ err- return (thresholdMin, thresholdMax)- Right (cmps, _) ->- case lookup v cmps of- Nothing -> do- -- A missing comparison is not necessarily a bug - it may- -- simply mean that this comparison is inside a loop or- -- branch that is never reached for this dataset. In such- -- cases, the optimal range is universal.- when (optVerbose opts > 0) $ putStrLn "Irrelevant for dataset.\n"- return (thresholdMin, thresholdMax)- Just e_par -> do- t_run <- run path_t RunBenchmark- f_run <- run path_f RunBenchmark+ case sample_run of+ Left err -> do+ -- If the sampling run fails, we treat it as zero information.+ -- One of our ancestor thresholds will have be set such that+ -- this path is never taken.+ when (optVerbose opts > 0) $ putStrLn $+ "Sampling run failed:\n" ++ err+ return (tMin, tMax)+ Right (cmps, t) -> do+ let ePars = S.toAscList $+ S.map snd $+ S.filter (candidateEPar (tMin, tMax)) $+ S.fromList cmps - let prefer_t = (thresholdMin, e_par)- prefer_f = (e_par+1, thresholdMax)+ runner :: Int -> Int -> IO (Maybe Int)+ runner timeout' threshold = do+ res <- run timeout' ((v, threshold) : already_tuned)+ case res of+ Right (_, runTime) ->+ return $ Just runTime+ _ ->+ return Nothing - case (t_run, f_run) of- (Left err, _) -> do- when (optVerbose opts > 0) $- putStrLn $ "True comparison run failed:\n" ++ err- return prefer_f- (_, Left err) -> do- when (optVerbose opts > 0) $- putStrLn $ "False comparison run failed:\n" ++ err- return prefer_t- (Right (_, runtime_t), Right (_, runtime_f)) ->- if runtime_t < runtime_f- then do when (optVerbose opts > 0) $- putStrLn "True branch is fastest."- return prefer_t- else do when (optVerbose opts > 0) $- putStrLn "False branch is fastest."- return prefer_f+ when (optVerbose opts > 1) $+ putStrLn $ unwords ("Got ePars: " : map show ePars) - let (_lower, upper) = intersectRanges ranges- return $ (v,upper) : already_tuned+ newMax <- binarySearch runner (t, tMax) ePars+ let newMinIdx = pred <$> elemIndex newMax ePars+ let newMin = maximum $ catMaybes [Just tMin, newMinIdx]+ return (newMin, newMax) - where path = already_tuned ++ v_path- path_t = (v, thresholdMin) : path- path_f = (v, thresholdMax) : path+ bestPair :: [(Int, Int)] -> (Int, Int)+ bestPair = minimumBy (compare `on` fst) + timeout :: Int -> Int+ -- We wish to let datasets run for the untuned time + 20% + 1 second.+ timeout elapsed = ceiling (fromIntegral elapsed * 1.2 :: Double) + 1++ candidateEPar :: (Int, Int) -> (String, Int) -> Bool+ candidateEPar (tMin, tMax) (threshold, ePar) =+ ePar > tMin && ePar < tMax && threshold == v+++ binarySearch :: (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int+ binarySearch runner best@(best_t, best_e_par) xs =+ case splitAt (length xs `div` 2) xs of+ (lower, middle : middle' : upper) -> do+ when (optVerbose opts > 0) $+ putStrLn $ unwords ["Trying e_par", show middle,+ "and", show middle']+ candidate <- runner (timeout best_t) middle+ candidate' <- runner (timeout best_t) middle'+ case (candidate, candidate') of+ (Just new_t, Just new_t') ->+ if new_t < new_t' then+ -- recurse into lower half+ binarySearch runner (bestPair [(new_t, middle), best]) lower+ else+ -- recurse into upper half+ binarySearch runner (bestPair [(new_t', middle'), best]) upper+ (Just new_t, Nothing) ->+ -- recurse into lower half+ binarySearch runner (bestPair [(new_t, middle), best]) lower+ (Nothing, Just new_t') ->+ -- recurse into upper half+ binarySearch runner (bestPair [(new_t', middle'), best]) upper+ (Nothing, Nothing) -> do+ when (optVerbose opts > 2) $+ putStrLn $ unwords ["Timing failed for candidates",+ show middle, "and", show middle']+ return best_e_par+ (_, []) -> return best_e_par+ (_, [x]) -> do+ when (optVerbose opts > 0) $+ putStrLn $ unwords ["Trying e_par", show x]+ candidate <- runner (timeout best_t) x+ case candidate of+ Just new_t ->+ return $ snd $ bestPair [(new_t, x), best]+ Nothing ->+ return best_e_par+ --- CLI tune :: AutotuneOptions -> FilePath -> IO Path@@ -335,6 +348,15 @@ (ReqArg (\s -> Right $ \config -> config { optTuning = Just s }) "EXTENSION") "Write tuning files with this extension (default: .tuning)."+ , Option [] ["timeout"]+ (ReqArg (\n ->+ case reads n of+ [(n', "")] ->+ Right $ \config -> config { optTimeout = n' }+ _ ->+ Left $ error $ "'" ++ n ++ "' is not a non-negative integer.")+ "SECONDS")+ "Initial tuning timeout for each dataset. Later tuning runs are based off of the runtime of the first run." , Option "v" ["verbose"] (NoArg $ Right $ \config -> config { optVerbose = optVerbose config + 1 }) "Enable logging. Pass multiple times for more."
src/Futhark/CLI/Bench.hs view
@@ -42,11 +42,12 @@ , optEntryPoint :: Maybe String , optTuning :: Maybe String , optConcurrency :: Maybe Int+ , optVerbose :: Int } initialBenchOptions :: BenchOptions initialBenchOptions = BenchOptions "c" Nothing "" 10 [] [] Nothing (-1) False- ["nobench", "disable"] [] Nothing (Just "tuning") Nothing+ ["nobench", "disable"] [] Nothing (Just "tuning") Nothing 0 runBenchmarks :: BenchOptions -> [FilePath] -> IO () runBenchmarks opts paths = do@@ -162,6 +163,7 @@ , runRuns = optRuns opts , runExtraOptions = optExtraOptions opts , runTimeout = optTimeout opts+ , runVerbose = optVerbose opts } runBenchmarkCase :: BenchOptions -> FilePath -> T.Text -> Int -> TestRun@@ -275,6 +277,9 @@ Left $ error $ "'" ++ n ++ "' is not a positive integer.") "NUM") "Number of benchmarks to prepare (not run) concurrently."+ , Option "v" ["verbose"]+ (NoArg $ Right $ \config -> config { optVerbose = optVerbose config + 1 })+ "Enable logging. Pass multiple times for more." ] where max_timeout :: Int max_timeout = maxBound `div` 1000000
src/Futhark/CLI/C.hs view
@@ -8,7 +8,6 @@ import Futhark.Pipeline import Futhark.Passes import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI import Futhark.Util @@ -16,8 +15,7 @@ main = compilerMain () [] "Compile sequential C" "Generate sequential C code from optimised Futhark program." sequentialCpuPipeline $ \() mode outpath prog -> do- cprog <- either (`internalError` prettyText prog) return =<<- SequentialC.compileProg prog+ cprog <- SequentialC.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h"
src/Futhark/CLI/CSOpenCL.hs view
@@ -8,10 +8,9 @@ import System.Exit import System.FilePath -import Futhark.Pipeline import Futhark.Passes+import Futhark.Pipeline import qualified Futhark.CodeGen.Backends.CSOpenCL as CSOpenCL-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI import Futhark.Util @@ -24,8 +23,7 @@ let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing- csprog <- either (`internalError` prettyText prog) return =<<- CSOpenCL.compileProg class_name prog+ csprog <- CSOpenCL.compileProg class_name prog let cspath = outpath `addExtension` "cs" liftIO $ writeFile cspath csprog
src/Futhark/CLI/CSharp.hs view
@@ -11,7 +11,6 @@ import Futhark.Pipeline import Futhark.Passes import qualified Futhark.CodeGen.Backends.SequentialCSharp as SequentialCS-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI import Futhark.Util @@ -23,8 +22,7 @@ let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing- csprog <- either (`internalError` prettyText prog) return =<<- SequentialCS.compileProg class_name prog+ csprog <- SequentialCS.compileProg class_name prog let cspath = outpath `addExtension` "cs" liftIO $ writeFile cspath csprog
src/Futhark/CLI/CUDA.hs view
@@ -9,15 +9,13 @@ import Futhark.Passes import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA import Futhark.Util-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI main :: String -> [String] -> IO () main = compilerMain () [] "Compile CUDA" "Generate CUDA/C code from optimised Futhark program." gpuPipeline $ \() mode outpath prog -> do- cprog <- either (`internalError` prettyText prog) return =<<- CCUDA.compileProg prog+ cprog <- CCUDA.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h" extra_options = [ "-lcuda"
src/Futhark/CLI/Dev.hs view
@@ -163,7 +163,7 @@ externalErrorS $ "Pass " ++ name ++" expects Kernels representation, but got " ++ representation rep -typedPassOption :: (Checkable fromlore, Checkable tolore) =>+typedPassOption :: Checkable tolore => (String -> UntypedPassState -> FutharkM (Prog fromlore)) -> (Prog tolore -> UntypedPassState) -> Pass fromlore tolore@@ -299,7 +299,6 @@ , typedPassOption soacsProg Kernels firstOrderTransform "f" , soacsPassOption fuseSOACs "o" , soacsPassOption inlineFunctions []- , soacsPassOption inlineConstants [] , kernelsPassOption inPlaceLowering [] , kernelsPassOption babysitKernels [] , kernelsPassOption tileLoops []
src/Futhark/CLI/OpenCL.hs view
@@ -10,15 +10,13 @@ import Futhark.Passes import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL import Futhark.Util-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI main :: String -> [String] -> IO () main = compilerMain () [] "Compile OpenCL" "Generate OpenCL/C code from optimised Futhark program." gpuPipeline $ \() mode outpath prog -> do- cprog <- either (`internalError` prettyText prog) return =<<- COpenCL.compileProg prog+ cprog <- COpenCL.compileProg prog let cpath = outpath `addExtension` "c" hpath = outpath `addExtension` "h" extra_options
src/Futhark/CLI/Pkg.hs view
@@ -21,8 +21,6 @@ import System.Console.GetOpt import qualified Codec.Archive.Zip as Zip-import Network.HTTP.Client-import Network.HTTP.Client.TLS import Prelude @@ -40,7 +38,7 @@ let putEntry from_dir pdir entry -- The archive may contain all kinds of other stuff that we don't want. | not (isInPkgDir from_dir $ Zip.eRelativePath entry)- || hasTrailingPathSeparator (Zip.eRelativePath entry) = return ()+ || hasTrailingPathSeparator (Zip.eRelativePath entry) = return Nothing | otherwise = do -- Since we are writing to paths indicated in a zipfile we -- downloaded from the wild Internet, we are going to be a@@ -56,6 +54,7 @@ let f = pdir </> makeRelative from_dir (Zip.eRelativePath entry) createDirectoryIfMissing True $ takeDirectory f LBS.writeFile f $ Zip.fromEntry entry+ return $ Just f isInPkgDir from_dir f = Posix.splitPath from_dir `isPrefixOf` Posix.splitPath f@@ -82,8 +81,13 @@ liftIO $ removePathForcibly pdir liftIO $ createDirectoryIfMissing True pdir - liftIO $ mapM_ (putEntry from_dir pdir) $ Zip.zEntries a+ written <-+ catMaybes <$> liftIO (mapM (putEntry from_dir pdir) $ Zip.zEntries a) + when (null written) $+ fail $ "Zip archive for package " ++ T.unpack p +++ " does not contain any files in " ++ from_dir+ libDir, libNewDir, libOldDir :: FilePath (libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old") @@ -186,7 +190,7 @@ instance MonadLogger PkgM where addLog l = do verbose <- asks pkgVerbose- when verbose $ liftIO $ T.hPutStr stderr $ toText l+ when verbose $ liftIO $ T.hPutStrLn stderr $ toText l runPkgM :: PkgConfig -> PkgM a -> IO a runPkgM cfg (PkgM m) = evalStateT (runReaderT m cfg) mempty@@ -354,9 +358,6 @@ main :: String -> [String] -> IO () main prog args = do- -- Ensure that we can make HTTPS requests.- setGlobalManager =<< newManager tlsManagerSettings- -- Avoid Git asking for credentials. We prefer failure. liftIO $ setEnv "GIT_TERMINAL_PROMPT" "0"
src/Futhark/CLI/PyOpenCL.hs view
@@ -5,10 +5,8 @@ import System.FilePath import System.Directory -import Futhark.Pipeline import Futhark.Passes import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI main :: String -> [String] -> IO ()@@ -18,8 +16,7 @@ let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing- pyprog <- either (`internalError` prettyText prog) return =<<- PyOpenCL.compileProg class_name prog+ pyprog <- PyOpenCL.compileProg class_name prog case mode of ToLibrary ->
src/Futhark/CLI/Python.hs view
@@ -5,10 +5,8 @@ import System.FilePath import System.Directory -import Futhark.Pipeline import Futhark.Passes import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy-import Futhark.Util.Pretty (prettyText) import Futhark.Compiler.CLI main :: String -> [String] -> IO ()@@ -18,8 +16,7 @@ let class_name = case mode of ToLibrary -> Just $ takeBaseName outpath ToExecutable -> Nothing- pyprog <- either (`internalError` prettyText prog) return =<<- SequentialPy.compileProg class_name prog+ pyprog <- SequentialPy.compileProg class_name prog case mode of ToLibrary ->
src/Futhark/CLI/Test.hs view
@@ -29,7 +29,7 @@ import Futhark.Analysis.Metrics import Futhark.Test import Futhark.Util.Options-import Futhark.Util.Pretty (prettyText)+import Futhark.Util.Pretty (prettyText, inRed) import Futhark.Util.Table --- Test execution@@ -472,9 +472,6 @@ putStr excluded_str exitWith $ case testStatusFail ts of 0 -> ExitSuccess _ -> ExitFailure 1--inRed :: String -> String-inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] --- --- Configuration and command line parsing
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -14,7 +14,6 @@ import qualified Futhark.CodeGen.Backends.GenericC as GC import qualified Futhark.CodeGen.ImpGen.CUDA as ImpGen-import Futhark.Error import Futhark.Representation.ExplicitMemory hiding (GetSize, CmpSizeLe, GetSizeMax) import Futhark.MonadFreshNames import Futhark.CodeGen.ImpCode.OpenCL@@ -22,16 +21,14 @@ import Futhark.CodeGen.Backends.CCUDA.Boilerplate import Futhark.CodeGen.Backends.GenericC.Options -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError GC.CParts)+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m GC.CParts compileProg prog = do- res <- ImpGen.compileProg prog- case res of- Left err -> return $ Left err- Right (Program cuda_code cuda_prelude kernel_names _ sizes failures prog') ->- let extra = generateBoilerplate cuda_code cuda_prelude- kernel_names sizes failures- in Right <$> GC.compileProg operations extra cuda_includes- [Space "device", DefaultSpace] cliOptions prog'+ (Program cuda_code cuda_prelude kernel_names _ sizes failures prog') <-+ ImpGen.compileProg prog+ let extra = generateBoilerplate cuda_code cuda_prelude+ kernel_names sizes failures+ GC.compileProg operations extra cuda_includes+ [Space "device", DefaultSpace] cliOptions prog' where operations :: GC.Operations OpenCL () operations = GC.defaultOperations@@ -141,10 +138,10 @@ num_elems <- case vs of ArrayValues vs' -> do let vs'' = [[C.cinit|$exp:v|] | v <- map GC.compilePrimValue vs']- GC.libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|]+ GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|] return $ length vs'' ArrayZeros n -> do- GC.libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]+ 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
src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs view
@@ -23,7 +23,7 @@ -> [FailureMsg] -> GC.CompilerM OpenCL () () generateBoilerplate cuda_program cuda_prelude kernels sizes failures = do- GC.earlyDecls [C.cunit|+ mapM_ GC.earlyDecl [C.cunit| $esc:("#include <cuda.h>") $esc:("#include <nvrtc.h>") $esc:("typedef CUdeviceptr fl_mem_t;")@@ -48,9 +48,9 @@ size_class_inits = map (\c -> [C.cinit|$string:(pretty c)|]) $ M.elems sizes num_sizes = M.size sizes - GC.libDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|]- GC.libDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|]- GC.libDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|] GC.publicDef_ "get_num_sizes" GC.InitDecl $ \s -> ([C.cedecl|int $id:s(void);|],@@ -74,7 +74,7 @@ generateConfigFuns sizes = do let size_decls = map (\k -> [C.csdecl|size_t $id:k;|]) $ M.keys sizes num_sizes = M.size sizes- GC.libDecl [C.cedecl|struct sizes { $sdecls:size_decls };|]+ GC.earlyDecl [C.cedecl|struct sizes { $sdecls:size_decls };|] cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ([C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s { struct cuda_config cu_cfg;@@ -265,6 +265,7 @@ return NULL; } ctx->profiling = ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging;+ ctx->error = NULL; ctx->cuda.cfg = cfg->cu_cfg; create_lock(&ctx->lock);@@ -285,12 +286,19 @@ $stms:final_inits $stms:set_sizes + init_constants(ctx);+ // Clear the free list of any deallocations that occurred while initialising constants.+ CUDA_SUCCEED(cuda_free_all(&ctx->cuda));++ futhark_context_sync(ctx);+ return ctx; }|]) GC.publicDef_ "context_free" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:ctx* ctx);|], [C.cedecl|void $id:s(struct $id:ctx* ctx) {+ free_constants(ctx); cuda_cleanup(&ctx->cuda); free_lock(&ctx->lock); free(ctx);@@ -321,6 +329,7 @@ return 1; } }+ return 0; }|]) GC.publicDef_ "context_get_error" GC.InitDecl $ \s ->
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -13,7 +13,6 @@ import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C -import Futhark.Error import Futhark.Representation.ExplicitMemory hiding (GetSize, CmpSizeLe, GetSizeMax) import Futhark.CodeGen.Backends.COpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericC as GC@@ -22,22 +21,19 @@ import qualified Futhark.CodeGen.ImpGen.OpenCL as ImpGen import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError GC.CParts)+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m GC.CParts compileProg prog = do- res <- ImpGen.compileProg prog- case res of- Left err -> return $ Left err- Right (Program opencl_code opencl_prelude kernels- types sizes failures prog') -> do- let cost_centres =- [copyDevToDev, copyDevToHost, copyHostToDev,- copyScalarToDev, copyScalarFromDev]- ++ M.keys kernels- Right <$> GC.compileProg operations- (generateBoilerplate opencl_code opencl_prelude- cost_centres kernels types sizes failures)- include_opencl_h [Space "device", DefaultSpace]- cliOptions prog'+ (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+ (generateBoilerplate opencl_code opencl_prelude+ cost_centres kernels types sizes failures)+ include_opencl_h [Space "device", DefaultSpace]+ cliOptions prog' where operations :: GC.Operations OpenCL () operations = GC.defaultOperations { GC.opsCompiler = callKernel@@ -50,7 +46,8 @@ , GC.opsMemoryType = openclMemoryType , GC.opsFatMemory = True }- include_opencl_h = unlines ["#define CL_USE_DEPRECATED_OPENCL_1_2_APIS",+ include_opencl_h = unlines ["#define CL_TARGET_OPENCL_VERSION 120",+ "#define CL_USE_DEPRECATED_OPENCL_1_2_APIS", "#ifdef __APPLE__", "#define CL_SILENCE_DEPRECATION", "#include <OpenCL/cl.h>",@@ -222,10 +219,10 @@ num_elems <- case vs of ArrayValues vs' -> do let vs'' = [[C.cinit|$exp:v|] | v <- map GC.compilePrimValue vs']- GC.libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|]+ GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|] return $ length vs'' ArrayZeros n -> do- GC.libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]+ 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
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -66,16 +66,16 @@ let (ctx_opencl_fields, ctx_opencl_inits, top_decls, later_top_decls) = openClDecls profiling_centres kernels opencl_code opencl_prelude - GC.earlyDecls top_decls+ mapM_ GC.earlyDecl top_decls let size_name_inits = map (\k -> [C.cinit|$string:(pretty k)|]) $ M.keys sizes size_var_inits = map (\k -> [C.cinit|$string:(zEncodeString (pretty k))|]) $ M.keys sizes size_class_inits = map (\c -> [C.cinit|$string:(pretty c)|]) $ M.elems sizes num_sizes = M.size sizes - GC.libDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|]- GC.libDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|]- GC.libDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|]+ GC.earlyDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|] GC.publicDef_ "get_num_sizes" GC.InitDecl $ \s -> ([C.cedecl|int $id:s(void);|],@@ -96,7 +96,7 @@ }|]) let size_decls = map (\k -> [C.csdecl|size_t $id:k;|]) $ M.keys sizes- GC.libDecl [C.cedecl|struct sizes { $sdecls:size_decls };|]+ GC.earlyDecl [C.cedecl|struct sizes { $sdecls:size_decls };|] cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ([C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s { struct opencl_config opencl;@@ -285,9 +285,9 @@ typename cl_int failure_is_an_option; };|]) - mapM_ GC.libDecl later_top_decls+ mapM_ GC.earlyDecl later_top_decls - GC.libDecl [C.cedecl|static void init_context_early(struct $id:cfg *cfg, struct $id:ctx* ctx) {+ GC.earlyDecl [C.cedecl|static void init_context_early(struct $id:cfg *cfg, struct $id:ctx* ctx) { ctx->opencl.cfg = cfg->opencl; ctx->detail_memory = cfg->opencl.debugging; ctx->debugging = cfg->opencl.debugging;@@ -312,7 +312,7 @@ max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures - GC.libDecl [C.cedecl|static int init_context_late(struct $id:cfg *cfg, struct $id:ctx* ctx, typename cl_program prog) {+ GC.earlyDecl [C.cedecl|static int init_context_late(struct $id:cfg *cfg, struct $id:ctx* ctx, typename cl_program prog) { typename cl_int error; typename cl_int no_error = -1;@@ -335,7 +335,11 @@ $stms:final_inits $stms:set_sizes - return 0;+ init_constants(ctx);+ // Clear the free list of any deallocations that occurred while initialising constants.+ OPENCL_SUCCEED_OR_RETURN(opencl_free_all(&ctx->opencl));++ return futhark_context_sync(ctx); }|] let set_required_types = [ [C.cstm|required_types |= OPENCL_F64; |]@@ -354,11 +358,8 @@ init_context_early(cfg, ctx); typename cl_program prog = setup_opencl(&ctx->opencl, opencl_program, required_types, cfg->build_opts);- if (init_context_late(cfg, ctx, prog) == 0) {- return ctx;- } else {- return NULL;- }+ init_context_late(cfg, ctx, prog);+ return ctx; }|]) GC.publicDef_ "context_new_with_command_queue" GC.InitDecl $ \s ->@@ -381,6 +382,7 @@ GC.publicDef_ "context_free" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:ctx* ctx);|], [C.cedecl|void $id:s(struct $id:ctx* ctx) {+ free_constants(ctx); free_lock(&ctx->lock); opencl_tally_profiling_records(&ctx->opencl); free(ctx->opencl.profiling_records);@@ -497,14 +499,6 @@ program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] openCL_boilerplate = [C.cunit|-- $esc:("#define CL_USE_DEPRECATED_OPENCL_1_2_APIS")- $esc:("#define CL_SILENCE_DEPRECATION // For macOS.")- $esc:("#ifdef __APPLE__")- $esc:(" #include <OpenCL/cl.h>")- $esc:("#else")- $esc:(" #include <CL/cl.h>")- $esc:("#endif") $esc:("typedef cl_mem fl_mem_t;") $esc:free_list_h $esc:openCL_h@@ -642,10 +636,10 @@ if (equals != NULL) { *equals = 0; if (futhark_context_config_set_size(cfg, name, value) != 0) {- panic(1, "Unknown size: %s\n", name);+ futhark_panic(1, "Unknown size: %s\n", name); } } else {- panic(1, "Invalid argument for size option: %s\n", optarg);+ futhark_panic(1, "Invalid argument for size option: %s\n", optarg); }}|] } , Option { optionLongName = "tuning"@@ -655,7 +649,7 @@ char *ret = load_tuning_file(optarg, cfg, (int(*)(void*, const char*, size_t)) futhark_context_config_set_size); if (ret != NULL) {- panic(1, "When loading tuning from '%s': %s\n", optarg, ret);+ futhark_panic(1, "When loading tuning from '%s': %s\n", optarg, ret); }}|] } ]
src/Futhark/CodeGen/Backends/CSOpenCL.hs view
@@ -6,7 +6,6 @@ import Control.Monad import Data.List (intersperse) -import Futhark.Error import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory, int32) import Futhark.CodeGen.Backends.CSOpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericCSharp as CS@@ -19,25 +18,23 @@ import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Maybe String- -> Prog ExplicitMemory -> m (Either InternalError String)+compileProg :: MonadFreshNames m =>+ Maybe String -> Prog ExplicitMemory -> m String compileProg module_name prog = do- res <- ImpGen.compileProg prog- case res of- Left err -> return $ Left err- Right (Imp.Program opencl_code opencl_prelude kernel_names types sizes failures prog') ->- Right <$> 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'+ 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@@ -124,15 +121,16 @@ CS.stm $ Reassign (Var (CS.compileName v)) $ Field (Var "Ctx.Sizes") $ zEncodeString $ pretty key -callKernel (Imp.GetSizeMax v size_class) =- CS.stm $ Reassign (Var (CS.compileName 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.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@@ -145,8 +143,9 @@ where mult_exp = BinOp "*" callKernel (Imp.CmpSizeLe v key x) = do+ v' <- CS.compileVar v x' <- CS.compileExp x- CS.stm $ Reassign (Var (CS.compileName v)) $+ 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 ()@@ -211,8 +210,10 @@ err <- newVName' "setargErr" dest <- newVName "kArgDest" let err_var = Var err- return [ Fixed (Var $ CS.compileName dest) (Addr mem)- [ Assign err_var $ getKernelCall kernel argnum (CS.sizeOf $ Primitive IntPtrT) (Var $ CS.compileName dest)]+ 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@@ -229,9 +230,8 @@ -> CS.CompilerM op s [CSStmt] processKernelArg kernel argnum (Imp.ValueKArg e et) = processValueArg kernel argnum et =<< CS.compileExp e- processKernelArg kernel argnum (Imp.MemKArg v) =- processMemArg kernel argnum $ memblockFromMem v+ processMemArg kernel argnum . memblockFromMem =<< CS.compileVar v processKernelArg kernel argnum (Imp.SharedMemoryKArg (Imp.Count num_bytes)) = do err <- newVName' "setargErr"@@ -303,19 +303,17 @@ allocateOpenCLBuffer :: CS.Allocate Imp.OpenCL () allocateOpenCLBuffer mem size "device" = do- let mem' = CS.compileName mem errcode <- CS.compileName <$> newVName "errCode" CS.stm $ AssignTyped computeErrCodeT (Var errcode) Nothing- CS.stm $ Reassign (Var mem') (CS.simpleCall "MemblockAllocDevice" [Ref $ Var "Ctx", Var mem', size, String mem'])+ 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- let destmem' = Var $ CS.compileName destmem ptr <- newVName' "ptr"- CS.stm $ Fixed (Var ptr) (Addr $ Index destmem' $ IdxExp $ Integer 0)+ 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@@ -324,9 +322,8 @@ ] copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes _ = do- let srcmem' = CS.compileName srcmem ptr <- newVName' "ptr"- CS.stm $ Fixed (Var ptr) (Addr $ Index (Var srcmem') $ IdxExp $ Integer 0)+ 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@@ -350,8 +347,8 @@ staticOpenCLArray :: CS.StaticArray Imp.OpenCL () staticOpenCLArray name "device" t vs = do- let name' = CS.compileName name- CS.staticMemDecl $ AssignTyped (CustomT "OpenCLMemblock") (Var name') Nothing+ name' <- CS.compileVar name+ CS.staticMemDecl $ AssignTyped (CustomT "OpenCLMemblock") name' Nothing -- Create host-side C# array with intended values. tmp_arr <- newVName' "tmpArr"@@ -368,17 +365,20 @@ Imp.ArrayZeros n -> n size = Integer $ toInteger num_elems * Imp.primByteSize t - CS.staticMemAlloc $ Reassign (Var name') (CS.simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"])+ 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 (Var name') (CS.simpleCall "MemblockAllocDevice" [Ref $ Var "Ctx", Var name', size, String name'])+ 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+ [ Var "Ctx.OpenCL.Queue", memblockFromMem name', Bool True , CS.toIntPtr (Integer 0),CS.toIntPtr size , CS.toIntPtr $ Var ptr, Integer 0, Null, Null ] ]@@ -387,10 +387,8 @@ staticOpenCLArray _ space _ _ = error $ "CSOpenCL backend cannot create static array in memory space '" ++ space ++ "'" -memblockFromMem :: VName -> CSExp-memblockFromMem mem =- let mem' = Var $ CS.compileName mem- in Field mem' "Mem"+memblockFromMem :: CSExp -> CSExp+memblockFromMem mem = Field mem "Mem" packArrayOutput :: CS.EntryOutput Imp.OpenCL () packArrayOutput mem "device" bt ept dims = do@@ -414,12 +412,13 @@ 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"+ 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+ [ Var "Ctx.OpenCL.Queue", memblockFromMem mem', Bool True , CS.toIntPtr (Integer 0), CS.toIntPtr nbytes, CS.toIntPtr (Var ptr) , Integer 0, Null, Null] ]]
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -53,7 +53,7 @@ , profileReport , HeaderSection(..) , libDecl- , earlyDecls+ , earlyDecl , publicName , contextType , contextField@@ -86,7 +86,7 @@ import Futhark.CodeGen.Backends.SimpleRepresentation import Futhark.CodeGen.Backends.GenericC.Options import Futhark.Util (zEncodeString)-import Futhark.Representation.AST.Attributes (isBuiltInFunction, builtInFunctions)+import Futhark.Representation.AST.Attributes (isBuiltInFunction) data CompilerState s = CompilerState {@@ -234,10 +234,8 @@ error "The default compiler cannot compile extended operations" -data CompilerEnv op s = CompilerEnv {- envOperations :: Operations op s- , envFtable :: M.Map Name [Type]- }+newtype CompilerEnv op s = CompilerEnv+ { envOperations :: Operations op s } newtype CompilerAcc op s = CompilerAcc { accItems :: DL.DList C.BlockItem@@ -277,17 +275,8 @@ envFatMemory :: CompilerEnv op s -> Bool envFatMemory = opsFatMemory . envOperations -newCompilerEnv :: Functions op -> Operations op s- -> CompilerEnv op s-newCompilerEnv (Functions funs) ops =- CompilerEnv { envOperations = ops- , envFtable = ftable <> builtinFtable- }- where ftable = M.fromList $ map funReturn funs- funReturn (name, fun) =- (name, paramsTypes $ functionOutput fun)- builtinFtable =- M.map (map Scalar . snd) builtInFunctions+newCompilerEnv :: Operations op s -> CompilerEnv op s+newCompilerEnv ops = CompilerEnv { envOperations = ops } tupleDefinitions, arrayDefinitions, opaqueDefinitions :: CompilerState s -> [C.Definition] tupleDefinitions = map (snd . snd) . compTypeStructs@@ -330,11 +319,11 @@ getNameSource = gets compNameSrc putNameSource src = modify $ \s -> s { compNameSrc = src } -runCompilerM :: Functions op -> Operations op s -> VNameSource -> s+runCompilerM :: Operations op s -> VNameSource -> s -> CompilerM op s a -> (a, CompilerState s)-runCompilerM prog ops src userstate (CompilerM m) =- let (x, s, _) = runRWS m (newCompilerEnv prog ops) (newCompilerState src userstate)+runCompilerM ops src userstate (CompilerM m) =+ let (x, s, _) = runRWS m (newCompilerEnv ops) (newCompilerState src userstate) in (x, s) getUserState :: CompilerM op s s@@ -404,7 +393,7 @@ s' <- publicName s let (pub, priv) = f s' headerDecl h pub- libDecl priv+ earlyDecl priv return s' -- | As 'publicDef', but ignores the public name.@@ -421,9 +410,9 @@ libDecl def = modify $ \s -> s { compLibDecls = compLibDecls s <> DL.singleton def } -earlyDecls :: [C.Definition] -> CompilerM op s ()-earlyDecls def = modify $ \s ->- s { compEarlyDecls = compEarlyDecls s <> DL.fromList def }+earlyDecl :: C.Definition -> CompilerM op s ()+earlyDecl def = modify $ \s ->+ s { compEarlyDecls = compEarlyDecls s <> DL.singleton def } contextField :: String -> C.Type -> Maybe C.Exp -> CompilerM op s () contextField name ty initial = modify $ \s ->@@ -550,7 +539,7 @@ stm [C.cstm|block->mem = (char*) malloc(size);|] let allocdef = [C.cedecl|static int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) { if (size < 0) {- panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",+ futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n", (long long)size, desc, $string:spacedesc, ctx->$id:usagename); } int ret = $id:(fatMemUnRef space)(ctx, block, desc);@@ -678,13 +667,6 @@ $exp:srcmem + $exp:srcidx, $exp:nbytes);|] -paramsTypes :: [Param] -> [Type]-paramsTypes = map paramType- -- Let's hope we don't need the size for anything, because we are- -- just making something up.- where paramType (MemParam _ space) = Mem space- paramType (ScalarParam _ t) = Scalar t- --- Entry points. arrayName :: PrimType -> Signedness -> Int -> String@@ -1084,7 +1066,7 @@ readPrimStm :: C.ToExp a => a -> Int -> PrimType -> Signedness -> C.Stm readPrimStm place i t ept = [C.cstm|if (read_scalar(&$exp:(primTypeInfo t ept),&$exp:place) != 0) {- panic(1, "Error when reading input #%d of type %s (errno: %s).\n",+ futhark_panic(1, "Error when reading input #%d of type %s (errno: %s).\n", $int:i, $exp:(primTypeInfo t ept).type_name, strerror(errno));@@ -1095,7 +1077,7 @@ readInput :: Int -> ExternalValue -> CompilerM op s (C.Stm, C.Stm, C.Stm, C.Exp) readInput i (OpaqueValue desc _) = do- stm [C.cstm|panic(1, "Cannot read input #%d of type %s\n", $int:i, $string:desc);|]+ stm [C.cstm|futhark_panic(1, "Cannot read input #%d of type %s\n", $int:i, $string:desc);|] return ([C.cstm|;|], [C.cstm|;|], [C.cstm|;|], [C.cexp|NULL|]) readInput i (TransparentValue (ScalarValue t ept _)) = do dest <- newVName "read_value"@@ -1127,7 +1109,7 @@ $id:shape, $int:(length dims)) != 0) {- panic(1, "Cannot read input #%d of type %s%s (errno: %s).\n",+ futhark_panic(1, "Cannot read input #%d of type %s%s (errno: %s).\n", $int:i, $string:dims_s, $exp:(primTypeInfo t ept).type_name,@@ -1194,7 +1176,7 @@ /* Run the program once. */ $stms:pack_input if ($id:sync_ctx(ctx) != 0) {- panic(1, "%s", $id:error_ctx(ctx));+ futhark_panic(1, "%s", $id:error_ctx(ctx)); }; // Only profile last run. if (profile_run) {@@ -1205,10 +1187,10 @@ $args:(map addrOf output_vals), $args:input_args); if (r != 0) {- panic(1, "%s", $id:error_ctx(ctx));+ futhark_panic(1, "%s", $id:error_ctx(ctx)); } if ($id:sync_ctx(ctx) != 0) {- panic(1, "%s", $id:error_ctx(ctx));+ futhark_panic(1, "%s", $id:error_ctx(ctx)); }; if (profile_run) { $id:pause_profiling(ctx);@@ -1233,7 +1215,7 @@ $items:input_items if (end_of_input() != 0) {- panic(1, "Expected EOF on stdin after reading input for %s.\n", $string:(quote (pretty fname)));+ futhark_panic(1, "Expected EOF on stdin after reading input for %s.\n", $string:(quote (pretty fname))); } $items:output_decls@@ -1306,14 +1288,14 @@ where set_runtime_file = [C.cstm|{ runtime_file = fopen(optarg, "w"); if (runtime_file == NULL) {- panic(1, "Cannot open %s: %s\n", optarg, strerror(errno));+ futhark_panic(1, "Cannot open %s: %s\n", optarg, strerror(errno)); } }|] set_num_runs = [C.cstm|{ num_runs = atoi(optarg); perform_warmup = 1; if (num_runs <= 0) {- panic(1, "Need a positive number of runs, not %s\n", optarg);+ futhark_panic(1, "Need a positive number of runs, not %s\n", optarg); } }|] @@ -1331,7 +1313,8 @@ -- | Produce header and implementation files. asLibrary :: CParts -> (String, String)-asLibrary parts = ("#pragma once\n\n" <> cHeader parts, cUtils parts <> cLib parts)+asLibrary parts = ("#pragma once\n\n" <> cHeader parts,+ cHeader parts <> cUtils parts <> cLib parts) -- | As executable with command-line interface. asExecutable :: CParts -> String@@ -1345,12 +1328,12 @@ -> String -> [Space] -> [Option]- -> Functions op+ -> Definitions op -> m CParts-compileProg ops extra header_extra spaces options prog@(Functions funs) = do+compileProg ops extra header_extra spaces options prog = do src <- getNameSource let ((prototypes, definitions, entry_points), endstate) =- runCompilerM prog ops src () compileProg'+ runCompilerM ops src () compileProg' (entry_point_decls, cli_entry_point_decls, entry_point_inits) = unzip3 entry_points option_parser = generateOptionParser "parse_options" $ benchmarkOptions++options@@ -1390,7 +1373,7 @@ $esc:("#undef NDEBUG") $esc:("#include <assert.h>") -$esc:panic_h+$esc:futhark_panic_h $esc:timing_h |]@@ -1442,12 +1425,17 @@ argv += parsed_options; if (argc != 0) {- panic(1, "Excess non-option: %s\n", argv[0]);+ futhark_panic(1, "Excess non-option: %s\n", argv[0]); } struct futhark_context *ctx = futhark_context_new(cfg); assert (ctx != NULL); + char* error = futhark_context_get_error(ctx);+ if (error != NULL) {+ futhark_panic(1, "%s", error);+ }+ if (entry_point != NULL) { int num_entry_points = sizeof(entry_points) / sizeof(entry_points[0]); entry_point_fun *entry_point_fun = NULL;@@ -1492,18 +1480,20 @@ $esc:("#include <errno.h>") $esc:("#include <assert.h>") +$esc:(header_extra)+ $esc:lock_h +$edecls:builtin+ $edecls:early_decls +$edecls:prototypes+ $edecls:lib_decls $edecls:(tupleDefinitions endstate) -$edecls:prototypes--$edecls:builtin- $edecls:(map funcToDef definitions) $edecls:(arrayDefinitions endstate)@@ -1516,14 +1506,19 @@ return $ CParts (pretty headerdefs) (pretty utildefs) (pretty clidefs) (pretty libdefs) where compileProg' = do+ let Definitions consts (Functions funs) = prog+ (memstructs, memfuns, memreport) <- unzip3 <$> mapM defineMemorySpace spaces - (prototypes, definitions) <- unzip <$> mapM compileFun funs+ get_consts <- compileConstants consts - mapM_ libDecl memstructs- entry_points <- mapM (uncurry onEntryPoint) $ filter (functionEntry . snd) funs+ (prototypes, definitions) <- unzip <$> mapM (compileFun get_consts) funs++ mapM_ earlyDecl memstructs+ entry_points <-+ mapM (uncurry onEntryPoint) $ filter (functionEntry . snd) funs extra- mapM_ libDecl $ concat memfuns+ mapM_ earlyDecl $ concat memfuns profilereport <- gets $ DL.toList . compProfileItems ctx_ty <- contextType@@ -1547,14 +1542,70 @@ builtin = cIntOps ++ cFloat32Ops ++ cFloat64Ops ++ cFloatConvOps ++ cFloat32Funs ++ cFloat64Funs - panic_h = $(embedStringFile "rts/c/panic.h")+ futhark_panic_h = $(embedStringFile "rts/c/panic.h") values_h = $(embedStringFile "rts/c/values.h") timing_h = $(embedStringFile "rts/c/timing.h") lock_h = $(embedStringFile "rts/c/lock.h") tuning_h = $(embedStringFile "rts/c/tuning.h") -compileFun :: (Name, Function op) -> CompilerM op s (C.Definition, C.Func)-compileFun (fname, Function _ outputs inputs body _ _) = do+compileConstants :: Constants op -> CompilerM op s [C.BlockItem]+compileConstants (Constants ps init_consts) = do+ ctx_ty <- contextType+ const_fields <- mapM constParamField ps+ contextField "constants" [C.cty|struct { $sdecls:const_fields }|] Nothing+ earlyDecl [C.cedecl|int init_constants($ty:ctx_ty*);|]+ earlyDecl [C.cedecl|int free_constants($ty:ctx_ty*);|]++ -- We locally define macros for the constants, so that when we+ -- generate assignments to local variables, we actually assign into+ -- the constants struct. This is not needed for functions, because+ -- they can only read constants, not write them.+ let (defs, undefs) = unzip $ map constMacro ps+ init_consts' <- blockScope $ do+ mapM_ resetMemConst ps+ compileCode init_consts+ libDecl [C.cedecl|int init_constants($ty:ctx_ty *ctx) {+ $items:defs+ $items:init_consts'+ $items:undefs+ return 0;+ }|]++ free_consts <- collect $ mapM_ freeConst ps+ libDecl [C.cedecl|int free_constants($ty:ctx_ty *ctx) {+ $items:free_consts+ return 0;+ }|]++ mapM getConst ps++ where constParamField (ScalarParam name bt) = do+ let ctp = primTypeToCType bt+ return [C.csdecl|$ty:ctp $id:name;|]+ constParamField (MemParam name space) = do+ ty <- memToCType space+ return [C.csdecl|$ty:ty $id:name;|]++ constMacro p = ([C.citem|$escstm:def|], [C.citem|$escstm:undef|])+ where p' = pretty (C.toIdent (paramName p) mempty)+ def = "#define " ++ p' ++ " (" ++ "ctx->constants." ++ p' ++ ")"+ undef = "#undef " ++ p'++ resetMemConst ScalarParam{} = return ()+ resetMemConst (MemParam name space) = resetMem name space++ freeConst ScalarParam{} = return ()+ freeConst (MemParam name space) = unRefMem [C.cexp|ctx->constants.$id:name|] space++ getConst (ScalarParam name bt) = do+ let ctp = primTypeToCType bt+ return [C.citem|$ty:ctp $id:name = ctx->constants.$id:name;|]+ getConst (MemParam name space) = do+ ty <- memToCType space+ return [C.citem|$ty:ty $id:name = ctx->constants.$id:name;|]++compileFun :: [C.BlockItem] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func)+compileFun get_constants (fname, Function _ outputs inputs body _ _) = do (outparams, out_ptrs) <- unzip <$> mapM compileOutput outputs inparams <- mapM compileInput inputs body' <- blockScope $ compileFunBody out_ptrs outputs body@@ -1563,6 +1614,7 @@ $params:outparams, $params:inparams);|], [C.cfun|static int $id:(funName fname)($ty:ctx_ty *ctx, $params:outparams, $params:inparams) {+ $items:get_constants $items:body' return 0; }|])@@ -1889,9 +1941,9 @@ case vs of ArrayValues vs' -> do let vs'' = [[C.cinit|$exp:(compilePrimValue v)|] | v <- vs']- libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|]+ earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|] ArrayZeros n ->- libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]+ earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] -- Fake a memory block. contextField (pretty name) [C.cty|struct memblock|] $@@ -1925,10 +1977,8 @@ case dests of [dest] | isBuiltInFunction fname -> stm [C.cstm|$id:dest = $id:(funName fname)($args:args'');|]- _ -> do- ret <- newVName "call_ret"- item [C.citem|int $id:ret = $id:(funName fname)($args:args'');|]- stm [C.cstm|assert($id:ret == 0);|]+ _ ->+ item [C.citem|if ($id:(funName fname)($args:args'') != 0) { return 1; }|] where compileArg (MemArg m) = return [C.cexp|$exp:m|] compileArg (ExpArg e) = compileExp e
src/Futhark/CodeGen/Backends/GenericC/Options.hs view
@@ -50,11 +50,11 @@ getopt_long(argc, argv, $string:option_string, long_options, NULL)) != -1) { $stms:option_applications if ($id:chosen_option == ':') {- panic(-1, "Missing argument for option %s\n", argv[optind-1]);+ futhark_panic(-1, "Missing argument for option %s\n", argv[optind-1]); } if ($id:chosen_option == '?') { fprintf(stderr, "Usage: %s: %s\n", fut_progname, $string:option_descriptions);- panic(1, "Unknown option: %s\n", argv[optind-1]);+ futhark_panic(1, "Unknown option: %s\n", argv[optind-1]); } } return optind;
src/Futhark/CodeGen/Backends/GenericCSharp.hs view
@@ -11,6 +11,7 @@ , assignScalarPointer , toIntPtr , compileName+ , compileVar , compileDim , compileExp , compileCode@@ -70,7 +71,7 @@ import Control.Monad.RWS import Control.Arrow((&&&)) import Data.Maybe-import qualified Data.Map.Strict as M+import qualified Data.Map as M import Futhark.Representation.Primitive hiding (Bool) import Futhark.MonadFreshNames@@ -80,7 +81,6 @@ import Futhark.CodeGen.Backends.GenericCSharp.Options import Futhark.CodeGen.Backends.GenericCSharp.Definitions import Futhark.Util (zEncodeString)-import Futhark.Representation.AST.Attributes (builtInFunctions) -- | A substitute expression compiler, tried before the main -- compilation function.@@ -88,22 +88,22 @@ -- | Write a scalar to the given memory block with the given index and -- in the given memory space.-type WriteScalar op s = VName -> CSExp -> PrimType -> Imp.SpaceId -> CSExp+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 = VName -> CSExp -> PrimType -> Imp.SpaceId+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 = VName -> CSExp -> Imp.SpaceId+type Allocate op s = CSExp -> CSExp -> Imp.SpaceId -> CompilerM op s () -- | Copy from one memory block to another.-type Copy op s = VName -> CSExp -> Imp.Space ->- VName -> CSExp -> Imp.Space ->+type Copy op s = CSExp -> CSExp -> Imp.Space ->+ CSExp -> CSExp -> Imp.Space -> CSExp -> PrimType -> CompilerM op s () @@ -111,7 +111,7 @@ 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 = VName -> Imp.SpaceId ->+type EntryOutput op s = CSExp -> Imp.SpaceId -> PrimType -> Imp.Signedness -> [Imp.DimSize] -> CompilerM op s CSExp@@ -167,10 +167,10 @@ defSyncRun = Pass -data CompilerEnv op s = CompilerEnv {- envOperations :: Operations op s- , envFtable :: M.Map Name [Imp.Type]-}+data CompilerEnv op s = CompilerEnv+ { envOperations :: Operations op s+ , envVarExp :: M.Map VName CSExp+ } data CompilerAcc op s = CompilerAcc { accItems :: [CSStmt]@@ -211,14 +211,10 @@ envSyncFun :: CompilerEnv op s -> CSStmt envSyncFun = opsSyncRun . envOperations -newCompilerEnv :: Imp.Functions op -> Operations op s -> CompilerEnv op s-newCompilerEnv (Imp.Functions funs) ops =+newCompilerEnv :: Operations op s -> CompilerEnv op s+newCompilerEnv ops = CompilerEnv { envOperations = ops- , envFtable = ftable <> builtinFtable- }- where ftable = M.fromList $ map funReturn funs- funReturn (name, Imp.Function _ outparams _ _ _ _) = (name, paramsTypes outparams)- builtinFtable = M.map (map Imp.Scalar . snd) builtInFunctions+ , envVarExp = mempty } data CompilerState s = CompilerState { compNameSrc :: VNameSource@@ -230,7 +226,7 @@ , compUserState :: s , compMemberDecls :: [CSStmt] , compAssignedVars :: [VName]- , compDeclaredMem :: [(VName, Space)]+ , compDeclaredMem :: [(CSExp, Space)] } newCompilerState :: VNameSource -> s -> CompilerState s@@ -315,9 +311,6 @@ futharkFun :: String -> String futharkFun s = "futhark_" ++ zEncodeString s -paramsTypes :: [Imp.Param] -> [Imp.Type]-paramsTypes = map paramType- paramType :: Imp.Param -> Imp.Type paramType (Imp.MemParam _ space) = Imp.Mem space paramType (Imp.ScalarParam _ t) = Imp.Scalar t@@ -337,14 +330,13 @@ getDefaultDecl (Imp.ScalarParam v t) = Assign (Var $ compileName v) $ simpleInitClass (compilePrimType t) [] --runCompilerM :: Imp.Functions op -> Operations op s+runCompilerM :: Operations op s -> VNameSource -> s -> CompilerM op s a -> a-runCompilerM prog ops src userstate (CompilerM m) =- fst $ evalRWS m (newCompilerEnv prog ops) (newCompilerState src userstate)+runCompilerM ops src userstate (CompilerM m) =+ fst $ evalRWS m (newCompilerEnv ops) (newCompilerState src userstate) standardOptions :: [Option] standardOptions = [@@ -401,11 +393,11 @@ -> [CSStmt] -> [Space] -> [Option]- -> Imp.Functions op+ -> Imp.Definitions op -> m String-compileProg module_name constructor imports defines ops userstate boilerplate pre_timing _ options prog@(Imp.Functions funs) = do+compileProg module_name constructor imports defines ops userstate boilerplate pre_timing _ options prog = do src <- getNameSource- let prog' = runCompilerM prog ops src userstate compileProg'+ let prog' = runCompilerM ops src userstate compileProg' let imports' = [ Using Nothing "System" , Using Nothing "System.Diagnostics" , Using Nothing "System.Collections"@@ -420,7 +412,9 @@ , Using Nothing "Mono.Options" ] ++ imports return $ pretty (CSProg $ imports' ++ prog')- where compileProg' = do+ where Imp.Definitions consts (Imp.Functions funs) = prog+ compileProg' = do+ compileConstants consts definitions <- mapM compileFunc funs opencl_boilerplate <- collect boilerplate compBeforeParses <- gets compBeforeParse@@ -511,6 +505,19 @@ , 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@@ -570,6 +577,10 @@ 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@@ -612,7 +623,7 @@ unpackDim arr_name (Imp.Var var) i = do let shape_name = Field arr_name "Item2" let src = Index shape_name $ IdxExp $ Integer $ toInteger i- let dest = Var $ compileName var+ dest <- compileVar var isAssigned <- getVarAssigned var if isAssigned then@@ -626,16 +637,17 @@ CreateSystemTuple <$> mapM (entryPointOutput . Imp.TransparentValue) vs entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) =- return $ cast $ Var $ compileName name+ cast <$> compileVar name where cast = compileTypecastExt bt ept entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do- unRefMem mem (Imp.Space sid)+ mem' <- compileVar mem+ unRefMem mem' (Imp.Space sid) pack_output <- asks envEntryOutput- pack_output mem sid bt ept dims+ pack_output mem' sid bt ept dims entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do- let src = Var $ compileName mem+ src <- compileVar mem let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ Right $ map compileDim dims] @@ -645,8 +657,8 @@ map (\idx -> Field e $ "Item" ++ show (idx :: Int)) [1..] entryPointInput (_, Imp.TransparentValue (Imp.ScalarValue bt _ name), e) = do- let vname' = Var $ compileName name- cast = compileTypecast bt+ 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@@ -657,8 +669,8 @@ entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem _ bt _ dims), e) = do zipWithM_ (unpackDim e) dims [0..] let arrayData = Field e "Item1"- let dest = Var $ compileName mem- unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt]+ dest <- compileVar mem+ let unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt] stm $ Assign dest unwrap_call extValueDescName :: Imp.ExternalValue -> String@@ -855,17 +867,16 @@ allocate <- asks envAllocate let size = Var (compileName name ++ "_nbytes")- dest = name'- src = name+ dest = Var $ compileName name'+ src = Var $ compileName name offset = Integer 0 case space of Space sid ->- allocate name' size sid+ allocate dest size sid _ ->- stm $ Reassign (Var (compileName name'))- (simpleCall "allocateMem" [size]) -- FIXME+ stm $ Reassign dest (simpleCall "allocateMem" [size]) -- FIXME copy dest offset space src offset space size (IntType Int64) -- FIXME- return $ Just (compileName name')+ return $ Just dest _ -> return Nothing prepareIn <- collect $ mapM_ entryPointInput $ zip3 [0..] args $@@ -875,14 +886,14 @@ let mem_copies = mapMaybe liftMaybe $ zip argexps_mem_copies inputs mem_copy_inits = map initCopy mem_copies - argexps_lib = map (compileName . Imp.paramName) inputs+ 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' (fmap Var argexps_lib)]- call_bin = [Reassign funTuple $ simpleCall fname' (fmap Var argexps_bin)]+ 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,@@ -904,12 +915,12 @@ declsfunction (Imp.TransparentValue v) = valueDescFun v declsfunction (Imp.OpaqueValue _ vs) = mapM_ valueDescFun vs -copyMemoryDefaultSpace :: VName -> CSExp -> VName -> CSExp -> CSExp ->+copyMemoryDefaultSpace :: CSExp -> CSExp -> CSExp -> CSExp -> CSExp -> CompilerM op s () copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes =- stm $ Exp $ simpleCall "Buffer.BlockCopy" [ Var (compileName srcmem), srcidx- , Var (compileName destmem), destidx,- nbytes]+ stm $ Exp $ simpleCall "Buffer.BlockCopy" [ srcmem, srcidx+ , destmem, destidx+ , nbytes] compileEntryFun :: [CSStmt] -> (Name, Imp.Function op) -> CompilerM op s CSFunDef@@ -1131,26 +1142,27 @@ compileExp (Imp.ValueExp v) = return $ compilePrimValue v compileExp (Imp.LeafExp (Imp.ScalarVar vname) _) =- return $ Var $ compileName 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- <*> pure src <*> compileExp iexp+ <*> compileVar src <*> compileExp iexp <*> pure restype <*> pure space compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) _ _) _) = do- let src' = compileName src+ src' <- compileVar src iexp' <- compileExp iexp- return $ Cast (Primitive $ CSInt Int8T) (Index (Var src') (IdxExp 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))- return $ simpleCall ("indexArray_" ++ bt') [Var $ compileName src, iexp'']+ src' <- compileVar src+ return $ simpleCall ("indexArray_" ++ bt') [src', iexp''] compileExp (Imp.BinOpExp op x y) = do (x', y', simple) <- compileBinOpLike x y@@ -1217,25 +1229,24 @@ [AssignOp "+" (Var i') (Var one)] -compileCode (Imp.SetScalar vname exp1) = do- let name' = Var $ compileName vname- exp1' <- compileExp exp1- stm $ Reassign name' exp1'+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 (Var $ compileName v) $ Bool True+ stm =<< Assign <$> compileVar v <*> pure (Bool True) compileCode (Imp.DeclareScalar v _ t) =- stm $ AssignTyped t' (Var $ compileName v) Nothing+ 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) =- stms [Assign (Var $ "init_"++name') $+compileCode (Imp.DeclareArray name _ t vs) = do+ name' <- compileVar name+ stms [Assign (Var $ "init_"++compileName name) $ simpleCall "unwrapArray" [ case vs of Imp.ArrayValues vs' ->@@ -1244,9 +1255,8 @@ CreateArray (compilePrimTypeToAST t) $ Left n , simpleCall "sizeof" [Var $ compilePrimType t] ]- , Assign (Var name') $ Var ("init_"++name')+ , Assign name' $ Var ("init_"++compileName name) ]- where name' = compileName name compileCode (Imp.Comment s code) = do code' <- blockScope $ compileCode code@@ -1265,62 +1275,61 @@ compileCode (Imp.Call dests fname args) = do args' <- mapM compileArg args- let dests' = tupleOrSingle $ fmap Var (map compileName dests)- fname' = futharkFun (pretty fname)+ 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) = return $ Var $ compileName m+ where compileArg (Imp.MemArg m) = compileVar m compileArg (Imp.ExpArg e) = compileExp e -compileCode (Imp.SetMem dest src DefaultSpace) = do- let src' = Var (compileName src)- let dest' = Var (compileName dest)- stm $ Reassign dest' src'+compileCode (Imp.SetMem dest src DefaultSpace) =+ stm =<< Reassign <$> compileVar dest <*> compileVar src compileCode (Imp.SetMem dest src _) = do- let src' = Var (compileName src)- let dest' = Var (compileName dest)- stm $ Exp $ simpleCall "MemblockSetDevice" [Ref $ Var "Ctx", Ref dest', Ref src', String (compileName src)]+ 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- <*> pure name+ <*> compileVar name <*> compileExp e <*> pure space compileCode (Imp.Allocate name (Imp.Count e) _) = do e' <- compileExp e let allocate' = simpleCall "allocateMem" [e']- name' = Var (compileName name)- stm $ Reassign name' allocate'+ stm =<< Reassign <$> compileVar name <*> pure allocate' compileCode (Imp.Free name space) = do- unRefMem name space+ 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- let dest' = Var (compileName dest)- let src' = Var (compileName src)+ dest' <- compileVar dest+ src' <- compileVar src size' <- compileExp size- stm $ Exp $ simpleCall "Buffer.BlockCopy" [src', srcoffset', dest', destoffset',- Cast (Primitive $ CSInt Int32T) 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- <$> pure dest <*> compileExp destoffset <*> pure destspace- <*> pure src <*> compileExp srcoffset <*> pure srcspace+ <$> 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- <*> pure dest+ <*> compileVar dest <*> compileExp idx <*> pure elemtype <*> pure space@@ -1329,8 +1338,8 @@ compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do idx' <- compileExp idx elemexp' <- compileExp elemexp- let dest' = Var $ compileName dest- elemtype' = compileTypecast elemtype+ dest' <- compileVar dest+ let elemtype' = compileTypecast elemtype ctype = elemtype' elemexp' idx'' = BinOp "*" idx' (sizeOf (compilePrimTypeToAST elemtype)) @@ -1353,11 +1362,12 @@ releases <- collect $ mapM_ (uncurry unRefMem) new_allocs return (x, items <> releases) -unRefMem :: VName -> Space -> CompilerM op s ()+unRefMem :: CSExp -> Space -> CompilerM op s () unRefMem mem (Space "device") =- (stm . Exp) $ simpleCall "MemblockUnrefDevice" [ Ref $ Var "Ctx"- , (Ref . Var . compileName) mem- , (String . compileName) mem]+ 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"@@ -1369,14 +1379,21 @@ declMem :: VName -> Space -> CompilerM op s () declMem name space = do- modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s}- stm $ declMem' (compileName name) space+ name' <- compileVar name+ modify $ \s -> s { compDeclaredMem = (name', space) : compDeclaredMem s}+ stm $ declMem' name' space -declMem' :: String -> Space -> CSStmt-declMem' name (Space _) =- AssignTyped (CustomT "OpenCLMemblock") (Var name) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"])+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) (Var name) Nothing+ AssignTyped (Composite $ ArrayT $ Primitive ByteT) name Nothing rawMemCSType :: Space -> CSType rawMemCSType (Space _) = CustomT "OpenCLMemblock"
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -9,6 +9,7 @@ , emptyConstructor , compileName+ , compileVar , compileDim , compileExp , compileCode@@ -50,7 +51,7 @@ import Control.Monad.Writer import Control.Monad.RWS import Data.Maybe-import qualified Data.Map.Strict as M+import qualified Data.Map as M import Futhark.Representation.Primitive hiding (Bool) import Futhark.MonadFreshNames@@ -60,7 +61,7 @@ import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.Util (zEncodeString)-import Futhark.Representation.AST.Attributes (builtInFunctions, isBuiltInFunction)+import Futhark.Representation.AST.Attributes (isBuiltInFunction) -- | A substitute expression compiler, tried before the main -- compilation function.@@ -68,22 +69,22 @@ -- | Write a scalar to the given memory block with the given index and -- in the given memory space.-type WriteScalar op s = VName -> PyExp -> PrimType -> Imp.SpaceId -> PyExp+type WriteScalar op s = PyExp -> PyExp -> PrimType -> Imp.SpaceId -> PyExp -> 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 = VName -> PyExp -> PrimType -> Imp.SpaceId+type ReadScalar op s = PyExp -> PyExp -> PrimType -> Imp.SpaceId -> CompilerM op s PyExp -- | 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 = VName -> PyExp -> Imp.SpaceId+type Allocate op s = PyExp -> PyExp -> Imp.SpaceId -> CompilerM op s () -- | Copy from one memory block to another.-type Copy op s = VName -> PyExp -> Imp.Space ->- VName -> PyExp -> Imp.Space ->+type Copy op s = PyExp -> PyExp -> Imp.Space ->+ PyExp -> PyExp -> Imp.Space -> PyExp -> PrimType -> CompilerM op s () @@ -97,7 +98,7 @@ CompilerM op s PyExp -- | Unpack the array being passed to an entry point.-type EntryInput op s = VName -> Imp.SpaceId ->+type EntryInput op s = PyExp -> Imp.SpaceId -> PrimType -> Imp.Signedness -> [Imp.DimSize] -> PyExp ->@@ -144,10 +145,10 @@ defEntryInput _ _ _ _ = error "Cannot accept array not in default memory space" -data CompilerEnv op s = CompilerEnv {- envOperations :: Operations op s- , envFtable :: M.Map Name [Imp.Type]-}+data CompilerEnv op s = CompilerEnv+ { envOperations :: Operations op s+ , envVarExp :: M.Map VName PyExp+ } envOpCompiler :: CompilerEnv op s -> OpCompiler op s envOpCompiler = opsCompiler . envOperations@@ -173,14 +174,9 @@ envEntryInput :: CompilerEnv op s -> EntryInput op s envEntryInput = opsEntryInput . envOperations -newCompilerEnv :: Imp.Functions op -> Operations op s -> CompilerEnv op s-newCompilerEnv (Imp.Functions funs) ops =- CompilerEnv { envOperations = ops- , envFtable = ftable <> builtinFtable- }- where ftable = M.fromList $ map funReturn funs- funReturn (name, Imp.Function _ outparams _ _ _ _) = (name, paramsTypes outparams)- builtinFtable = M.map (map Imp.Scalar . snd) builtInFunctions+newCompilerEnv :: Operations op s -> CompilerEnv op s+newCompilerEnv ops = CompilerEnv { envOperations = ops+ , envVarExp = mempty } data CompilerState s = CompilerState { compNameSrc :: VNameSource@@ -223,21 +219,16 @@ futharkFun :: String -> String futharkFun s = "futhark_" ++ zEncodeString s -paramsTypes :: [Imp.Param] -> [Imp.Type]-paramsTypes = map paramType- where paramType (Imp.MemParam _ space) = Imp.Mem space- paramType (Imp.ScalarParam _ t) = Imp.Scalar t- compileOutput :: [Imp.Param] -> [PyExp] compileOutput = map (Var . compileName . Imp.paramName) -runCompilerM :: Imp.Functions op -> Operations op s+runCompilerM :: Operations op s -> VNameSource -> s -> CompilerM op s a -> a-runCompilerM prog ops src userstate (CompilerM m) =- fst $ evalRWS m (newCompilerEnv prog ops) (newCompilerState src userstate)+runCompilerM ops src userstate (CompilerM m) =+ fst $ evalRWS m (newCompilerEnv ops) (newCompilerState src userstate) standardOptions :: [Option] standardOptions = [@@ -300,11 +291,11 @@ -> s -> [PyStmt] -> [Option]- -> Imp.Functions op+ -> Imp.Definitions op -> m String-compileProg module_name constructor imports defines ops userstate pre_timing options prog@(Imp.Functions funs) = do+compileProg module_name constructor imports defines ops userstate pre_timing options prog = do src <- getNameSource- let prog' = runCompilerM prog ops src userstate compileProg'+ let prog' = runCompilerM ops src userstate compileProg' maybe_shebang = case module_name of Nothing -> "#!/usr/bin/env python\n" Just _ -> ""@@ -316,7 +307,11 @@ defines ++ [Escape pyUtility] ++ prog')- where compileProg' = do+ where Imp.Definitions consts (Imp.Functions funs) = prog+ compileProg' = withConstantSubsts consts $ do++ compileConstants consts+ definitions <- mapM compileFunc funs at_inits <- gets compInit @@ -366,12 +361,25 @@ [Exp $ simpleCall "entry_point_fun" []] ] +withConstantSubsts :: Imp.Constants op -> CompilerM op s a -> CompilerM op s a+withConstantSubsts (Imp.Constants ps _) =+ local $ \env -> env { envVarExp = foldMap constExp ps }+ where constExp p =+ M.singleton (Imp.paramName p) $ Index (Var "self.constants") $+ IdxExp $ String $ pretty $ Imp.paramName p++compileConstants :: Imp.Constants op -> CompilerM op s ()+compileConstants (Imp.Constants _ init_consts) = do+ atInit $ Assign (Var "self.constants") $ Dict []+ mapM_ atInit =<< collect (compileCode init_consts)+ compileFunc :: (Name, Imp.Function op) -> CompilerM op s PyFunDef compileFunc (fname, Imp.Function _ outputs inputs body _ _) = do body' <- collect $ compileCode body let inputs' = map (compileName . Imp.paramName) inputs let ret = Return $ tupleOrSingle $ compileOutput outputs- return $ Def (futharkFun . nameToString $ fname) ("self" : inputs') (body'++[ret])+ return $ Def (futharkFun . nameToString $ fname) ("self" : inputs') $+ body'++[ret] tupleOrSingle :: [PyExp] -> PyExp tupleOrSingle [e] = e@@ -399,20 +407,23 @@ unpackDim arr_name (Imp.Var var) i = do let shape_name = Field arr_name "shape" src = Index shape_name $ IdxExp $ Integer $ toInteger i- stm $ Assign (Var $ compileName var) $ simpleCall "np.int32" [src]+ var' <- compileVar var+ stm $ Assign var' $ simpleCall "np.int32" [src] entryPointOutput :: Imp.ExternalValue -> CompilerM op s PyExp entryPointOutput (Imp.OpaqueValue desc vs) = simpleCall "opaque" . (String (pretty desc):) <$> mapM (entryPointOutput . Imp.TransparentValue) vs-entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) =- return $ simpleCall tf [Var $ compileName name]+entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = do+ name' <- compileVar name+ return $ simpleCall tf [name'] where tf = compilePrimToExtNp bt ept entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do pack_output <- asks envEntryOutput pack_output mem sid bt ept dims entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do- let cast = Cast (Var $ compileName mem) (compilePrimTypeExt bt ept)+ mem' <- compileVar mem+ let cast = Cast mem' (compilePrimTypeExt bt ept) return $ simpleCall "createArray" [cast, Tuple $ map compileDim dims] badInput :: Int -> PyExp -> String -> PyStmt@@ -434,8 +445,8 @@ map (Index (Field e "data") . IdxExp . Integer) [0..] entryPointInput (i, Imp.TransparentValue (Imp.ScalarValue bt s name), e) = do- let vname' = Var $ compileName name- -- HACK: A Numpy int64 will signal an OverflowError if we pass+ vname' <- compileVar name+ let -- HACK: A Numpy int64 will signal an OverflowError if we pass -- it a number bigger than 2**63. This does not happen if we -- pass e.g. int8 a number bigger than 2**7. As a workaround, -- we first go through the corresponding ctypes type, which does@@ -450,7 +461,8 @@ entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do unpack_input <- asks envEntryInput- unpack <- collect $ unpack_input mem sid bt ept dims e+ mem' <- compileVar mem+ unpack <- collect $ unpack_input mem' sid bt ept dims e stm $ Try unpack [Catch (Tuple [Var "TypeError", Var "AssertionError"]) [badInput i e $ concat (replicate (length dims) "[]") ++@@ -468,8 +480,8 @@ [] zipWithM_ (unpackDim e) dims [0..]- let dest = Var $ compileName mem- unwrap_call = simpleCall "unwrapArray" [e]+ dest <- compileVar mem+ let unwrap_call = simpleCall "unwrapArray" [e] stm $ Assign dest unwrap_call @@ -558,11 +570,13 @@ offset = Integer 0 case space of Space sid ->- allocate name' size sid+ allocate (Var (compileName name')) size sid _ -> stm $ Assign (Var (compileName name')) (simpleCall "allocateMem" [size]) -- FIXME- copy dest offset space src offset space size (IntType Int32) -- FIXME+ dest' <- compileVar dest+ src' <- compileVar src+ copy dest' offset space src' offset space size (IntType Int32) -- FIXME return $ Just $ compileName name' _ -> return Nothing @@ -580,13 +594,13 @@ prepareIn, call_lib, call_bin, prepareOut, zip results res, prepare_run) -copyMemoryDefaultSpace :: VName -> PyExp -> VName -> PyExp -> PyExp ->+copyMemoryDefaultSpace :: PyExp -> PyExp -> PyExp -> PyExp -> PyExp -> CompilerM op s () copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes = do let offset_call1 = simpleCall "addressOffset"- [Var (compileName destmem), destidx, Var "ct.c_byte"]+ [destmem, destidx, Var "ct.c_byte"] let offset_call2 = simpleCall "addressOffset"- [Var (compileName srcmem), srcidx, Var "ct.c_byte"]+ [srcmem, srcidx, Var "ct.c_byte"] stm $ Exp $ simpleCall "ct.memmove" [offset_call1, offset_call2, nbytes] compileEntryFun :: (Name, Imp.Function op)@@ -767,26 +781,31 @@ compilePrimValue (BoolValue v) = Bool v compilePrimValue Checked = Var "True" +compileVar :: VName -> CompilerM op s PyExp+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) _) =- return $ Var $ compileName vname+ compileVar vname compileExp (Imp.LeafExp (Imp.SizeOf t) _) = return $ simpleCall (compilePrimToNp $ IntType Int32) [Integer $ primByteSize t] compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) = join $ asks envReadScalar- <*> pure src <*> compileExp iexp+ <*> compileVar src <*> compileExp iexp <*> pure restype <*> pure space compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt _ _) _) = do iexp' <- compileExp iexp let bt' = compilePrimType bt- let nptype = compilePrimToNp bt- return $ simpleCall "indexArray" [Var $ compileName src, iexp', Var bt', Var nptype]+ nptype = compilePrimToNp bt+ src' <- compileVar src+ return $ simpleCall "indexArray" [src', iexp', Var bt', Var nptype] compileExp (Imp.BinOpExp op x y) = do (x', y', simple) <- compileBinOpLike x y@@ -861,14 +880,13 @@ stm $ For counter (simpleCall "range" [bound']) $ body' ++ [AssignOp "+" (Var i') (Var one)] -compileCode (Imp.SetScalar vname exp1) = do- let name' = Var $ compileName vname- exp1' <- compileExp exp1- stm $ Assign name' exp1'+compileCode (Imp.SetScalar name exp1) =+ stm =<< Assign <$> compileVar name <*> compileExp exp1 compileCode Imp.DeclareMem{} = return ()-compileCode (Imp.DeclareScalar v _ Cert) =- stm $ Assign (Var $ compileName v) $ Var "True"+compileCode (Imp.DeclareScalar v _ Cert) = do+ v' <- compileVar v+ stm $ Assign v' $ Var "True" compileCode Imp.DeclareScalar{} = return () compileCode (Imp.DeclareArray name (Space space) t vs) =@@ -876,6 +894,7 @@ pure name <*> pure space <*> pure t <*> pure vs compileCode (Imp.DeclareArray name _ t vs) = do+ let arr_name = compileName name <> "_arr" -- It is important to store the Numpy array in a temporary variable -- to prevent it from going "out-of-scope" before calling -- unwrapArray (which internally uses the .ctype method); see@@ -890,11 +909,10 @@ [Arg $ Integer $ fromIntegral n, ArgKeyword "dtype" $ Var $ compilePrimToNp t] atInit $- Assign (Field (Var "self") name') $+ Assign (Field (Var "self") (compileName name)) $ simpleCall "unwrapArray" [Field (Var "self") arr_name]- stm $ Assign (Var name') $ Field (Var "self") name'- where name' = compileName name- arr_name = name' <> "_arr"+ name' <- compileVar name+ stm $ Assign name' $ Field (Var "self") (compileName name) compileCode (Imp.Comment s code) = do code' <- collect $ compileCode code@@ -912,8 +930,8 @@ compileCode (Imp.Call dests fname args) = do args' <- mapM compileArg args- let dests' = tupleOrSingle $ fmap Var (map compileName dests)- fname'+ dests' <- tupleOrSingle <$> mapM compileVar dests+ let fname' | isBuiltInFunction fname = futharkFun (pretty fname) | otherwise = "self." ++ futharkFun (pretty fname) call' = simpleCall fname' args'@@ -922,34 +940,31 @@ stm $ if null dests then Exp call' else Assign dests' call'- where compileArg (Imp.MemArg m) = return $ Var $ compileName m+ where compileArg (Imp.MemArg m) = compileVar m compileArg (Imp.ExpArg e) = compileExp e -compileCode (Imp.SetMem dest src _) = do- let src' = Var (compileName src)- let dest' = Var (compileName dest)- stm $ Assign dest' src'+compileCode (Imp.SetMem dest src _) =+ stm =<< Assign <$> compileVar dest <*> compileVar src compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) = join $ asks envAllocate- <*> pure name+ <*> compileVar name <*> compileExp e <*> pure space compileCode (Imp.Allocate name (Imp.Count e) _) = do e' <- compileExp e let allocate' = simpleCall "allocateMem" [e']- name' = Var (compileName name)- stm $ Assign name' allocate'+ stm =<< Assign <$> compileVar name <*> pure allocate' compileCode (Imp.Free name _) =- stm $ Assign (Var (compileName name)) None+ stm =<< Assign <$> compileVar name <*> pure None compileCode (Imp.Copy dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do destoffset' <- compileExp destoffset srcoffset' <- compileExp srcoffset- let dest' = Var (compileName dest)- let src' = Var (compileName src)+ dest' <- compileVar dest+ src' <- compileVar src size' <- compileExp size let offset_call1 = simpleCall "addressOffset" [dest', destoffset', Var "ct.c_byte"] let offset_call2 = simpleCall "addressOffset" [src', srcoffset', Var "ct.c_byte"]@@ -958,13 +973,13 @@ compileCode (Imp.Copy dest (Imp.Count destoffset) destspace src (Imp.Count srcoffset) srcspace (Imp.Count size)) = do copy <- asks envCopy join $ copy- <$> pure dest <*> compileExp destoffset <*> pure destspace- <*> pure src <*> compileExp srcoffset <*> pure srcspace+ <$> compileVar dest <*> compileExp destoffset <*> pure destspace+ <*> compileVar src <*> compileExp srcoffset <*> pure srcspace <*> compileExp size <*> pure (IntType Int32) -- FIXME compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) = join $ asks envWriteScalar- <*> pure dest+ <*> compileVar dest <*> compileExp idx <*> pure elemtype <*> pure space@@ -973,9 +988,9 @@ compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do idx' <- compileExp idx elemexp' <- compileExp elemexp- let dest' = Var $ compileName dest+ dest' <- compileVar dest let elemtype' = compilePrimType elemtype- let ctype = simpleCall elemtype' [elemexp']+ ctype = simpleCall elemtype' [elemexp'] stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype] compileCode Imp.Skip = return ()
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -6,7 +6,6 @@ import Control.Monad import qualified Data.Map as M -import Futhark.Error import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory) import Futhark.CodeGen.Backends.PyOpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericPython as Py@@ -19,100 +18,98 @@ --maybe pass the config file rather than multiple arguments compileProg :: MonadFreshNames m =>- Maybe String -> Prog ExplicitMemory -> m (Either InternalError String)+ Maybe String -> Prog ExplicitMemory -> m String compileProg module_name prog = do- res <- ImpGen.compileProg prog- --could probably be a better why do to this..- case res of- Left err -> return $ Left err- Right (Imp.Program opencl_code opencl_prelude kernels types sizes failures prog') -> do- --prepare the strings for assigning the kernels and set them as global- let assign = unlines $- map (\x -> pretty $ Assign (Var ("self."++x++"_var"))- (Var $ "program."++x)) $- M.keys kernels+ 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)) $+ M.keys kernels - let defines =- [Assign (Var "synchronous") $ Bool False,- Assign (Var "preferred_platform") None,- Assign (Var "preferred_device") None,- Assign (Var "default_threshold") None,- Assign (Var "default_group_size") None,- Assign (Var "default_num_groups") None,- Assign (Var "default_tile_size") None,- Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude ++ opencl_code,- Escape pyValues,- Escape pyFunctions,- Escape pyPanic,- Escape pyTuning]- let imports = [Import "sys" Nothing,- Import "numpy" $ Just "np",- Import "ctypes" $ Just "ct",- Escape openClPrelude,- Import "pyopencl.array" Nothing,- Import "time" Nothing]+ let defines =+ [Assign (Var "synchronous") $ Bool False,+ Assign (Var "preferred_platform") None,+ Assign (Var "preferred_device") None,+ Assign (Var "default_threshold") None,+ Assign (Var "default_group_size") None,+ Assign (Var "default_num_groups") None,+ Assign (Var "default_tile_size") None,+ Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude ++ opencl_code,+ Escape pyValues,+ Escape pyFunctions,+ Escape pyPanic,+ Escape pyTuning] - let constructor = Py.Constructor [ "self"- , "command_queue=None"- , "interactive=False"- , "platform_pref=preferred_platform"- , "device_pref=preferred_device"- , "default_group_size=default_group_size"- , "default_num_groups=default_num_groups"- , "default_tile_size=default_tile_size"- , "default_threshold=default_threshold"- , "sizes=sizes"]- [Escape $ openClInit types assign sizes failures]- options = [ Option { optionLongName = "platform"- , optionShortName = Just 'p'- , optionArgument = RequiredArgument "str"- , optionAction =- [ Assign (Var "preferred_platform") $ Var "optarg" ]- }- , Option { optionLongName = "device"- , optionShortName = Just 'd'- , optionArgument = RequiredArgument "str"- , optionAction =- [ Assign (Var "preferred_device") $ Var "optarg" ]- }- , Option { optionLongName = "default-threshold"- , optionShortName = Nothing- , optionArgument = RequiredArgument "int"- , optionAction =- [ Assign (Var "default_threshold") $ Var "optarg" ]- }- , Option { optionLongName = "default-group-size"- , optionShortName = Nothing- , optionArgument = RequiredArgument "int"- , optionAction =- [ Assign (Var "default_group_size") $ Var "optarg" ]- }- , Option { optionLongName = "default-num-groups"- , optionShortName = Nothing- , optionArgument = RequiredArgument "int"- , optionAction =- [ Assign (Var "default_num_groups") $ Var "optarg" ]- }- , Option { optionLongName = "default-tile-size"- , optionShortName = Nothing- , optionArgument = RequiredArgument "int"- , optionAction =- [ Assign (Var "default_tile_size") $ Var "optarg" ]- }- , Option { optionLongName = "size"- , optionShortName = Nothing- , optionArgument = RequiredArgument "size_assignment"- , optionAction =- [Assign (Index (Var "sizes")- (IdxExp (Index (Var "optarg")- (IdxExp (Integer 0)))))- (Index (Var "optarg") (IdxExp (Integer 1)))- ]- }- ]+ let imports = [Import "sys" Nothing,+ Import "numpy" $ Just "np",+ Import "ctypes" $ Just "ct",+ Escape openClPrelude,+ Import "pyopencl.array" Nothing,+ Import "time" Nothing] - Right <$> Py.compileProg module_name constructor imports defines operations ()- [Exp $ Py.simpleCall "sync" [Var "self"]] options prog'+ let constructor = Py.Constructor [ "self"+ , "command_queue=None"+ , "interactive=False"+ , "platform_pref=preferred_platform"+ , "device_pref=preferred_device"+ , "default_group_size=default_group_size"+ , "default_num_groups=default_num_groups"+ , "default_tile_size=default_tile_size"+ , "default_threshold=default_threshold"+ , "sizes=sizes"]+ [Escape $ openClInit types assign sizes failures]+ options = [ Option { optionLongName = "platform"+ , optionShortName = Just 'p'+ , optionArgument = RequiredArgument "str"+ , optionAction =+ [ Assign (Var "preferred_platform") $ Var "optarg" ]+ }+ , Option { optionLongName = "device"+ , optionShortName = Just 'd'+ , optionArgument = RequiredArgument "str"+ , optionAction =+ [ Assign (Var "preferred_device") $ Var "optarg" ]+ }+ , Option { optionLongName = "default-threshold"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "int"+ , optionAction =+ [ Assign (Var "default_threshold") $ Var "optarg" ]+ }+ , Option { optionLongName = "default-group-size"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "int"+ , optionAction =+ [ Assign (Var "default_group_size") $ Var "optarg" ]+ }+ , Option { optionLongName = "default-num-groups"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "int"+ , optionAction =+ [ Assign (Var "default_num_groups") $ Var "optarg" ]+ }+ , Option { optionLongName = "default-tile-size"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "int"+ , optionAction =+ [ Assign (Var "default_tile_size") $ Var "optarg" ]+ }+ , Option { optionLongName = "size"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "size_assignment"+ , optionAction =+ [Assign (Index (Var "sizes")+ (IdxExp (Index (Var "optarg")+ (IdxExp (Integer 0)))))+ (Index (Var "optarg") (IdxExp (Integer 1)))+ ]+ }+ ]++ 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 { Py.opsCompiler = callKernel@@ -131,16 +128,19 @@ asLong x = Py.simpleCall "np.long" [x] callKernel :: Py.OpCompiler Imp.OpenCL ()-callKernel (Imp.GetSize v key) =- Py.stm $ Assign (Var (Py.compileName v)) $- Index (Var "self.sizes") (IdxExp $ String $ pretty key)+callKernel (Imp.GetSize v key) = do+ v' <- Py.compileVar v+ Py.stm $ Assign v' $+ Index (Var "self.sizes") (IdxExp $ String $ pretty key) callKernel (Imp.CmpSizeLe v key x) = do+ v' <- Py.compileVar v x' <- Py.compileExp x- Py.stm $ Assign (Var (Py.compileName v)) $+ Py.stm $ Assign v' $ BinOp "<=" (Index (Var "self.sizes") (IdxExp $ String $ pretty key)) x'-callKernel (Imp.GetSizeMax v size_class) =- Py.stm $ Assign (Var (Py.compileName v)) $- Var $ "self.max_" ++ pretty size_class+callKernel (Imp.GetSizeMax v size_class) = do+ v' <- Py.compileVar v+ Py.stm $ Assign v' $+ Var $ "self.max_" ++ pretty size_class callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do num_workgroups' <- mapM (fmap asLong . Py.compileExp) num_workgroups@@ -169,7 +169,8 @@ [Var "self.global_failure", Var "self.failure_is_an_option", Var "self.global_failure_args"]- Py.stm $ Exp $ Py.simpleCall (kernel_name' ++ ".set_args") $ failure_args ++ args'+ Py.stm $ Exp $ Py.simpleCall (kernel_name' ++ ".set_args") $+ failure_args ++ args' Py.stm $ Exp $ Py.simpleCall "cl.enqueue_nd_range_kernel" [Var "self.queue", Var kernel_name', kernel_dims', workgroup_dims'] finishIfSynchronous@@ -177,18 +178,17 @@ processKernelArg (Imp.ValueKArg e bt) = do e' <- Py.compileExp e return $ Py.simpleCall (Py.compilePrimToNp bt) [e']- processKernelArg (Imp.MemKArg v) = return $ Var $ Py.compileName v+ processKernelArg (Imp.MemKArg v) = Py.compileVar v processKernelArg (Imp.SharedMemoryKArg (Imp.Count num_bytes)) = do num_bytes' <- Py.compileExp num_bytes return $ Py.simpleCall "cl.LocalMemory" [asLong num_bytes'] writeOpenCLScalar :: Py.WriteScalar Imp.OpenCL () writeOpenCLScalar mem i bt "device" val = do- let mem' = Var $ Py.compileName mem let nparr = Call (Var "np.array") [Arg val, ArgKeyword "dtype" $ Var $ Py.compilePrimType bt] Py.stm $ Exp $ Call (Var "cl.enqueue_copy")- [Arg $ Var "self.queue", Arg mem', Arg nparr,+ [Arg $ Var "self.queue", Arg mem, Arg nparr, ArgKeyword "device_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), ArgKeyword "is_blocking" $ Var "synchronous"] @@ -199,13 +199,12 @@ readOpenCLScalar mem i bt "device" = do val <- newVName "read_res" let val' = Var $ pretty val- let mem' = Var $ Py.compileName mem let nparr = Call (Var "np.empty") [Arg $ Integer 1, ArgKeyword "dtype" (Var $ Py.compilePrimType bt)] Py.stm $ Assign val' nparr Py.stm $ Exp $ Call (Var "cl.enqueue_copy")- [Arg $ Var "self.queue", Arg val', Arg mem',+ [Arg $ Var "self.queue", Arg val', Arg mem, ArgKeyword "device_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), ArgKeyword "is_blocking" $ Var "synchronous"] Py.stm $ Exp $ Py.simpleCall "sync" [Var "self"]@@ -216,7 +215,7 @@ allocateOpenCLBuffer :: Py.Allocate Imp.OpenCL () allocateOpenCLBuffer mem size "device" =- Py.stm $ Assign (Var $ Py.compileName mem) $+ Py.stm $ Assign mem $ Py.simpleCall "opencl_alloc" [Var "self", size, String $ pretty mem] allocateOpenCLBuffer _ _ space =@@ -224,35 +223,29 @@ copyOpenCLMemory :: Py.Copy Imp.OpenCL () copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx (Imp.Space "device") nbytes bt = do- let srcmem' = Var $ Py.compileName srcmem- let destmem' = Var $ Py.compileName destmem let divide = BinOp "//" nbytes (Integer $ Imp.primByteSize bt)- let end = BinOp "+" destidx divide- let dest = Index destmem' (IdxRange destidx end)+ end = BinOp "+" destidx divide+ dest = Index destmem (IdxRange destidx end) Py.stm $ ifNotZeroSize nbytes $ Exp $ Call (Var "cl.enqueue_copy")- [Arg $ Var "self.queue", Arg dest, Arg srcmem',+ [Arg $ Var "self.queue", Arg dest, Arg srcmem, ArgKeyword "device_offset" $ asLong srcidx, ArgKeyword "is_blocking" $ Var "synchronous"] copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes bt = do- let destmem' = Var $ Py.compileName destmem- let srcmem' = Var $ Py.compileName srcmem let divide = BinOp "//" nbytes (Integer $ Imp.primByteSize bt)- let end = BinOp "+" srcidx divide- let src = Index srcmem' (IdxRange srcidx end)+ end = BinOp "+" srcidx divide+ src = Index srcmem (IdxRange srcidx end) Py.stm $ ifNotZeroSize nbytes $ Exp $ Call (Var "cl.enqueue_copy")- [Arg $ Var "self.queue", Arg destmem', Arg src,+ [Arg $ Var "self.queue", Arg destmem, Arg src, ArgKeyword "device_offset" $ asLong destidx, ArgKeyword "is_blocking" $ Var "synchronous"] copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx (Imp.Space "device") nbytes _ = do- let destmem' = Var $ Py.compileName destmem- let srcmem' = Var $ Py.compileName srcmem Py.stm $ ifNotZeroSize nbytes $ Exp $ Call (Var "cl.enqueue_copy")- [Arg $ Var "self.queue", Arg destmem', Arg srcmem',+ [Arg $ Var "self.queue", Arg destmem, Arg srcmem, ArgKeyword "dest_offset" $ asLong destidx, ArgKeyword "src_offset" $ asLong srcidx, ArgKeyword "byte_count" $ asLong nbytes]@@ -284,7 +277,7 @@ -- Create memory block on the device. static_mem <- newVName "static_mem" let size = Integer $ toInteger num_elems * Imp.primByteSize t- allocateOpenCLBuffer static_mem size "device"+ allocateOpenCLBuffer (Var (Py.compileName static_mem)) size "device" -- Copy Numpy array to the device memory block. Py.stm $ ifNotZeroSize size $@@ -304,12 +297,13 @@ error $ "PyOpenCL backend cannot create static array in memory space '" ++ space ++ "'" packArrayOutput :: Py.EntryOutput Imp.OpenCL ()-packArrayOutput mem "device" bt ept dims =+packArrayOutput mem "device" bt ept dims = do+ mem' <- Py.compileVar mem return $ Call (Var "cl.array.Array")- [Arg $ Var "self.queue",- Arg $ Tuple $ map Py.compileDim dims,- Arg $ Var $ Py.compilePrimTypeExt bt ept,- ArgKeyword "data" $ Var $ Py.compileName mem]+ [Arg $ Var "self.queue",+ Arg $ Tuple $ map Py.compileDim dims,+ Arg $ Var $ Py.compilePrimTypeExt bt ept,+ ArgKeyword "data" mem'] packArrayOutput _ sid _ _ _ = error $ "Cannot return array from " ++ sid ++ " space." @@ -325,20 +319,19 @@ let memsize' = Py.simpleCall "np.int64" [Field e "nbytes"] pyOpenCLArrayCase =- [Assign mem_dest $ Field e "data"]+ [Assign mem $ Field e "data"] numpyArrayCase <- Py.collect $ do allocateOpenCLBuffer mem memsize' "device" Py.stm $ ifNotZeroSize memsize' $ Exp $ Call (Var "cl.enqueue_copy") [Arg $ Var "self.queue",- Arg $ Var $ Py.compileName mem,+ Arg mem, Arg $ Call (Var "normaliseArray") [Arg e], ArgKeyword "is_blocking" $ Var "synchronous"] Py.stm $ If (BinOp "==" (Py.simpleCall "type" [e]) (Var "cl.array.Array")) pyOpenCLArrayCase numpyArrayCase- where mem_dest = Var $ Py.compileName mem unpackArrayInput _ sid _ _ _ _ = error $ "Cannot accept array from " ++ sid ++ " space."
src/Futhark/CodeGen/Backends/SequentialC.hs view
@@ -13,16 +13,15 @@ import qualified Language.C.Quote.OpenCL as C -import Futhark.Error import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError GC.CParts)+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m GC.CParts compileProg =- traverse (GC.compileProg operations generateContext "" [DefaultSpace] []) <=<+ GC.compileProg operations generateContext "" [DefaultSpace] [] <=< ImpGen.compileProg where operations :: GC.Operations Imp.Sequential () operations = GC.defaultOperations@@ -87,15 +86,18 @@ } ctx->detail_memory = cfg->debugging; ctx->debugging = cfg->debugging;+ ctx->profiling = cfg->debugging; ctx->error = NULL; create_lock(&ctx->lock); $stms:init_fields+ init_constants(ctx); return ctx; }|]) GC.publicDef_ "context_free" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:ctx* ctx);|], [C.cedecl|void $id:s(struct $id:ctx* ctx) {+ free_constants(ctx); free_lock(&ctx->lock); free(ctx); }|])
src/Futhark/CodeGen/Backends/SequentialCSharp.hs view
@@ -3,7 +3,6 @@ ) where import Control.Monad-import Futhark.Error import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen@@ -12,20 +11,20 @@ import Futhark.MonadFreshNames compileProg :: MonadFreshNames m =>- Maybe String -> Prog ExplicitMemory -> m (Either InternalError String)+ Maybe String -> Prog ExplicitMemory -> m String compileProg module_name = ImpGen.compileProg >=>- traverse (CS.compileProg- module_name- CS.emptyConstructor- []- []- operations- ()- empty- []- []- [])+ CS.compileProg+ module_name+ CS.emptyConstructor+ []+ []+ operations+ ()+ empty+ []+ []+ [] where operations :: CS.Operations Imp.Sequential () operations = CS.defaultOperations { CS.opsCompiler = const $ return ()
src/Futhark/CodeGen/Backends/SequentialPython.hs view
@@ -4,7 +4,6 @@ import Control.Monad -import Futhark.Error import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen@@ -14,15 +13,15 @@ import Futhark.MonadFreshNames compileProg :: MonadFreshNames m =>- Maybe String -> Prog ExplicitMemory -> m (Either InternalError String)+ Maybe String -> Prog ExplicitMemory -> m String compileProg module_name = ImpGen.compileProg >=>- traverse (GenericPython.compileProg- module_name- GenericPython.emptyConstructor- imports- defines- operations () [] [])+ GenericPython.compileProg+ module_name+ GenericPython.emptyConstructor+ imports+ defines+ operations () [] [] where imports = [Import "sys" Nothing, Import "numpy" $ Just "np", Import "ctypes" $ Just "ct",
src/Futhark/CodeGen/ImpCode.hs view
@@ -8,9 +8,11 @@ -- Originally inspired by the paper "Defunctionalizing Push Arrays" -- (FHPC '14). module Futhark.CodeGen.ImpCode- ( Functions (..)+ ( Definitions (..)+ , Functions (..) , Function , FunctionT (..)+ , Constants (..) , ValueDesc (..) , Signedness (..) , ExternalValue (..)@@ -79,6 +81,9 @@ paramName (MemParam name _) = name paramName (ScalarParam name _) = name +-- | A collection of imperative functions and constants.+data Definitions a = Definitions (Constants a) (Functions a)+ -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)] @@ -88,6 +93,15 @@ instance Monoid (Functions a) where mempty = Functions [] +-- | A collection of imperative constants.+data Constants a = Constants+ { constsDecl :: [Param]+ -- ^ The constants that are made available to the functions.+ , constsInit :: Code a+ -- ^ Setting the value of the constants. Note that this must not+ -- contain declarations of the names defined in 'constsDecl'.+ }+ data Signedness = TypeUnsigned | TypeDirect deriving (Eq, Show)@@ -239,11 +253,22 @@ -- Prettyprinting definitions. +instance Pretty op => Pretty (Definitions op) where+ ppr (Definitions consts funs) =+ ppr consts </> ppr funs+ instance Pretty op => Pretty (Functions op) where ppr (Functions funs) = stack $ intersperse mempty $ map ppFun funs where ppFun (name, fun) = text "Function " <> ppr name <> colon </> indent 2 (ppr fun) +instance Pretty op => Pretty (Constants op) where+ ppr (Constants decls code) =+ text "Constants:" </> indent 2 (stack $ map ppr decls) </>+ mempty </>+ text "Initialisation:" </>+ indent 2 (ppr code)+ instance Pretty op => Pretty (FunctionT op) where ppr (Function _ outs ins body results args) = text "Inputs:" </> block ins </>@@ -431,6 +456,10 @@ declaredIn (While _ body) = declaredIn body declaredIn (Comment _ body) = declaredIn body declaredIn _ = mempty++instance FreeIn a => FreeIn (Functions a) where+ freeIn' (Functions fs) =+ foldMap (freeIn' . functionBody . snd) fs instance FreeIn a => FreeIn (Code a) where freeIn' (x :>>: y) =
src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -29,7 +29,7 @@ import Futhark.Representation.AST.Pretty () import Futhark.Util.Pretty -type Program = Functions HostOp+type Program = Imp.Definitions HostOp type Function = Imp.Function HostOp -- | Host-level code that can call kernels. type Code = Imp.Code HostOp
src/Futhark/CodeGen/ImpCode/OpenCL.hs view
@@ -42,7 +42,7 @@ -- ^ Runtime-configurable constants. , openClFailures :: [FailureMsg] -- ^ Assertion failure error messages.- , hostFunctions :: Functions OpenCL+ , hostDefinitions :: Definitions OpenCL } -- | Something that can go wrong in a kernel. Part of the machinery
src/Futhark/CodeGen/ImpCode/Sequential.hs view
@@ -16,7 +16,7 @@ import Futhark.Util.Pretty -- | An imperative program.-type Program = Imp.Functions Sequential+type Program = Imp.Definitions Sequential -- | An imperative function. type Function = Imp.Function Sequential
src/Futhark/CodeGen/ImpGen.hs view
@@ -82,13 +82,14 @@ import Control.Monad.RWS hiding (mapM, forM) import Control.Monad.State hiding (mapM, forM, State) import Control.Monad.Writer hiding (mapM, forM)-import Control.Monad.Except hiding (mapM, forM)+import Data.Bifunctor (first)+import qualified Data.DList as DL import Data.Either import Data.Traversable import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe-import Data.List (find, sortOn)+import Data.List (find, foldl', sortOn) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.ImpCode@@ -99,7 +100,6 @@ import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun import Futhark.Construct (fullSliceNum) import Futhark.MonadFreshNames-import Futhark.Error import Futhark.Util -- | How to compile an 'Op'.@@ -220,12 +220,11 @@ newState :: VNameSource -> State lore op newState = State mempty mempty -newtype ImpM lore op a = ImpM (RWST (Env lore op) (Imp.Code op) (State lore op) (Either InternalError) a)+newtype ImpM lore op a = ImpM (RWS (Env lore op) (Imp.Code op) (State lore op) a) deriving (Functor, Applicative, Monad, MonadState (State lore op), MonadReader (Env lore op),- MonadWriter (Imp.Code op),- MonadError InternalError)+ MonadWriter (Imp.Code op)) instance MonadFreshNames (ImpM lore op) where getNameSource = gets stateNameSource@@ -247,8 +246,8 @@ runImpM :: ImpM lore op a -> Operations lore op -> Imp.Space -> Name -> State lore op- -> Either InternalError (a, State lore op, Imp.Code op)-runImpM (ImpM m) ops space fname = runRWST m $ newEnv ops space fname+ -> (a, State lore op, Imp.Code op)+runImpM (ImpM m) ops space fname = runRWS m $ newEnv ops space fname subImpM_ :: Operations lore op' -> ImpM lore op' a -> ImpM lore op (Imp.Code op')@@ -259,18 +258,17 @@ subImpM ops (ImpM m) = do env <- ask s <- get- case runRWST m env { envExpCompiler = opsExpCompiler ops+ let (x, s', code) =+ runRWS m env { envExpCompiler = opsExpCompiler ops , envStmsCompiler = opsStmsCompiler ops , envCopyCompiler = opsCopyCompiler ops , envOpCompiler = opsOpCompiler ops , envAllocCompilers = opsAllocCompilers ops } s { stateVTable = stateVTable s- , stateFunctions = mempty } of- Left err -> throwError err- Right (x, s', code) -> do- putNameSource $ stateNameSource s'- return (x, code)+ , stateFunctions = mempty }+ putNameSource $ stateNameSource s'+ return (x, code) -- | Execute a code generation action, returning the code that was -- emitted.@@ -305,19 +303,54 @@ hasFunction fname = gets $ \s -> let Imp.Functions fs = stateFunctions s in isJust $ lookup fname fs -compileProg :: (ExplicitMemorish lore, MonadFreshNames m) =>+constsVTable :: LetAttr lore ~ LetAttr ExplicitMemory =>+ Stms lore -> VTable lore+constsVTable = foldMap stmVtable+ where stmVtable (Let pat _ e) =+ foldMap (peVtable e) $ M.toList $+ mconcat $ map scopeOfPatElem $ patternElements pat+ peVtable e (name, info) =+ M.singleton name $ memBoundToVarEntry (Just e) $ infoAttr info++compileProg :: (ExplicitMemorish lore, FreeIn op, MonadFreshNames m) => Operations lore op -> Imp.Space- -> Prog lore -> m (Either InternalError (Imp.Functions op))-compileProg ops space prog =+ -> Prog lore -> m (Imp.Definitions op)+compileProg ops space (Prog consts funs) = modifyNameSource $ \src ->- case foldM compileFunDef' (newState src) (progFuns prog) of- Left err -> (Left err, src)- Right s -> (Right $ stateFunctions s, stateNameSource s)- where compileFunDef' s fdef = do- ((), s', _) <-- runImpM (compileFunDef fdef) ops space (funDefName fdef) s- return s'+ let s = (newState src) { stateVTable = constsVTable consts }+ s' =+ foldl' compileFunDef' s funs+ free_in_funs =+ freeIn (stateFunctions s')+ (consts', s'', _) =+ runImpM (compileConsts free_in_funs consts) ops space+ (nameFromString "val") s'+ in (Imp.Definitions consts' (stateFunctions s''),+ stateNameSource s')+ where compileFunDef' s fdef =+ let ((), s', _) =+ runImpM (compileFunDef fdef) ops space (funDefName fdef) s+ in s' +compileConsts :: Names -> Stms lore -> ImpM lore op (Imp.Constants op)+compileConsts used_consts stms = do+ code <- collect $ compileStms used_consts stms $ pure ()+ pure $ uncurry Imp.Constants $ first DL.toList $ extract code+ where -- Fish out those top-level declarations in the constant+ -- initialisation code that are free in the functions.+ extract (x Imp.:>>: y) =+ extract x <> extract y+ extract (Imp.DeclareMem name space)+ | name `nameIn` used_consts =+ (DL.singleton $ Imp.MemParam name space,+ mempty)+ extract (Imp.DeclareScalar name _ t)+ | name `nameIn` used_consts =+ (DL.singleton $ Imp.ScalarParam name t,+ mempty)+ extract s =+ (mempty, s)+ compileInParam :: ExplicitMemorish lore => FParam lore -> ImpM lore op (Either Imp.Param ArrayDecl) compileInParam fparam = case paramAttr fparam of@@ -413,7 +446,7 @@ mkExts _ _ = return ([], []) mkParam MemMem{} _ =- compilerBugS "Functions may not explicitly return memory blocks."+ error "Functions may not explicitly return memory blocks." mkParam (MemPrim t) ept = do out <- imp $ newVName "scalar_out" tell ([Imp.ScalarParam out t], mempty)@@ -716,7 +749,7 @@ return () defCompileBasicOp pat e =- compilerBugS $ "ImpGen.defCompileBasicOp: Invalid pattern\n " +++ error $ "ImpGen.defCompileBasicOp: Invalid pattern\n " ++ pretty pat ++ "\nfor expression\n " ++ pretty e -- | Note: a hack to be used only for functions.@@ -733,9 +766,9 @@ -- Note: a hack to be used only for functions. addFParams :: ExplicitMemorish lore => [FParam lore] -> ImpM lore op () addFParams = mapM_ addFParam- where addFParam fparam = do- entry <- memBoundToVarEntry Nothing $ noUniquenessReturns $ paramAttr fparam- addVar (paramName fparam) entry+ where addFParam fparam =+ addVar (paramName fparam) $+ memBoundToVarEntry Nothing $ noUniquenessReturns $ paramAttr fparam -- | Another hack. addLoopVar :: VName -> IntType -> ImpM lore op ()@@ -782,21 +815,28 @@ return $ Imp.var name' $ primExpType e memBoundToVarEntry :: Maybe (Exp lore) -> MemBound NoUniqueness- -> ImpM lore op (VarEntry lore)+ -> VarEntry lore memBoundToVarEntry e (MemPrim bt) =- return $ ScalarVar e ScalarEntry { entryScalarType = bt }+ ScalarVar e ScalarEntry { entryScalarType = bt } memBoundToVarEntry e (MemMem space) =- return $ MemVar e $ MemEntry space-memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) = do+ MemVar e $ MemEntry space+memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) = let location = MemLocation mem (shapeDims shape) $ fmap (toExp' int32) ixfun- return $ ArrayVar e ArrayEntry { entryArrayLocation = location- , entryArrayElemType = bt- }+ in ArrayVar e ArrayEntry { entryArrayLocation = location+ , entryArrayElemType = bt+ } +infoAttr :: NameInfo ExplicitMemory+ -> MemInfo SubExp NoUniqueness MemBind+infoAttr (LetInfo attr) = attr+infoAttr (FParamInfo attr) = noUniquenessReturns attr+infoAttr (LParamInfo attr) = attr+infoAttr (IndexInfo it) = MemPrim $ IntType it+ dInfo :: Maybe (Exp lore) -> VName -> NameInfo ExplicitMemory -> ImpM lore op () dInfo e name info = do- entry <- memBoundToVarEntry e $ infoAttr info+ let entry = memBoundToVarEntry e $ infoAttr info case entry of MemVar _ entry' -> emit $ Imp.DeclareMem name $ entryMemSpace entry'@@ -805,18 +845,14 @@ ArrayVar _ _ -> return () addVar name entry- where infoAttr (LetInfo attr) = attr- infoAttr (FParamInfo attr) = noUniquenessReturns attr- infoAttr (LParamInfo attr) = attr- infoAttr (IndexInfo it) = MemPrim $ IntType it dScope :: Maybe (Exp lore) -> Scope ExplicitMemory -> ImpM lore op () dScope e = mapM_ (uncurry $ dInfo e) . M.toList dArray :: VName -> PrimType -> ShapeBase SubExp -> MemBind -> ImpM lore op ()-dArray name bt shape membind = do- entry <- memBoundToVarEntry Nothing $ MemArray bt shape NoUniqueness membind- addVar name entry+dArray name bt shape membind =+ addVar name $+ memBoundToVarEntry Nothing $ MemArray bt shape NoUniqueness membind everythingVolatile :: ImpM lore op a -> ImpM lore op a everythingVolatile = local $ \env -> env { envVolatility = Imp.Volatile }@@ -847,7 +883,7 @@ lookupVar v >>= \case ScalarVar _ (ScalarEntry pt) -> return $ Imp.var v pt- _ -> compilerBugS $ "toExp SubExp: SubExp is not a primitive type: " ++ pretty v+ _ -> error $ "toExp SubExp: SubExp is not a primitive type: " ++ pretty v toExp' _ (Constant v) = Imp.ValueExp v toExp' t (Var v) = Imp.var v t@@ -882,21 +918,21 @@ res <- gets $ M.lookup name . stateVTable case res of Just entry -> return entry- _ -> compilerBugS $ "Unknown variable: " ++ pretty name+ _ -> error $ "Unknown variable: " ++ pretty name lookupArray :: VName -> ImpM lore op ArrayEntry lookupArray name = do res <- lookupVar name case res of ArrayVar _ entry -> return entry- _ -> compilerBugS $ "ImpGen.lookupArray: not an array: " ++ pretty name+ _ -> error $ "ImpGen.lookupArray: not an array: " ++ pretty name lookupMemory :: VName -> ImpM lore op MemEntry lookupMemory name = do res <- lookupVar name case res of MemVar _ entry -> return entry- _ -> compilerBugS $ "Unknown memory block: " ++ pretty name+ _ -> error $ "Unknown memory block: " ++ pretty name destinationFromPattern :: ExplicitMemorish lore => Pattern lore -> ImpM lore op Destination destinationFromPattern pat =@@ -1031,19 +1067,19 @@ -> ImpM lore op () copyDWIMDest _ _ (Constant v) (_:_) =- compilerBugS $+ error $ unwords ["copyDWIMDest: constant source", pretty v, "cannot be indexed."] copyDWIMDest pat dest_slice (Constant v) [] = case mapM dimFix dest_slice of Nothing ->- compilerBugS $+ error $ unwords ["copyDWIMDest: constant source", pretty v, "with slice destination."] Just dest_is -> case pat of ScalarDestination name -> emit $ Imp.SetScalar name $ Imp.ValueExp v MemoryDestination{} ->- compilerBugS $+ error $ unwords ["copyDWIMDest: constant source", pretty v, "cannot be written to memory destination."] ArrayDestination (Just dest_loc) -> do (dest_mem, dest_space, dest_i) <-@@ -1051,7 +1087,7 @@ vol <- asks envVolatility emit $ Imp.Write dest_mem dest_i bt dest_space vol $ Imp.ValueExp v ArrayDestination Nothing ->- compilerBugS "copyDWIMDest: ArrayDestination Nothing"+ error "copyDWIMDest: ArrayDestination Nothing" where bt = primValueType v copyDWIMDest dest dest_slice (Var src) src_slice = do@@ -1061,19 +1097,19 @@ emit $ Imp.SetMem mem src space (MemoryDestination{}, _) ->- compilerBugS $+ error $ unwords ["copyDWIMDest: cannot write", pretty src, "to memory destination."] (_, MemVar{}) ->- compilerBugS $+ error $ unwords ["copyDWIMDest: source", pretty src, "is a memory block."] (_, ScalarVar _ (ScalarEntry _)) | not $ null src_slice ->- compilerBugS $+ error $ unwords ["copyDWIMDest: prim-typed source", pretty src, "with slice", pretty src_slice] (ScalarDestination name, _) | not $ null dest_slice ->- compilerBugS $+ error $ unwords ["copyDWIMDest: prim-typed target", pretty name, "with slice", pretty dest_slice] (ScalarDestination name, ScalarVar _ (ScalarEntry pt)) ->@@ -1087,7 +1123,7 @@ vol <- asks envVolatility emit $ Imp.SetScalar name $ Imp.index mem i bt space vol | otherwise ->- compilerBugS $+ error $ unwords ["copyDWIMDest: prim-typed target and array-typed source", pretty src, "with slice", pretty src_slice] @@ -1102,7 +1138,7 @@ vol <- asks envVolatility emit $ Imp.Write dest_mem dest_i bt dest_space vol (Imp.var src bt) | otherwise ->- compilerBugS $+ error $ unwords ["copyDWIMDest: array-typed target and prim-typed source", pretty src, "with slice", pretty dest_slice] @@ -1148,7 +1184,7 @@ Nothing -> emit $ Imp.Allocate (patElemName mem) e' space Just allocator' -> allocator' (patElemName mem) e' compileAlloc pat _ _ =- compilerBugS $ "compileAlloc: Invalid pattern: " ++ pretty pat+ error $ "compileAlloc: Invalid pattern: " ++ pretty pat -- | The number of bytes needed to represent the array in a -- straightforward contiguous format.@@ -1169,7 +1205,7 @@ i' <- newVName i it <- case primExpType bound of IntType it -> return it- t -> compilerBugS $ "sFor: bound " ++ pretty bound ++ " is of type " ++ pretty t+ t -> error $ "sFor: bound " ++ pretty bound ++ " is of type " ++ pretty t addLoopVar i' it body' <- collect $ body $ Imp.var i' $ IntType it emit $ Imp.For i' it bound body'
src/Futhark/CodeGen/ImpGen/CUDA.hs view
@@ -2,13 +2,11 @@ ( compileProg ) where -import Futhark.Error import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog ExplicitMemory- -> m (Either InternalError OpenCL.Program)-compileProg prog = either Left kernelsToCUDA <$> ImpGenKernels.compileProg prog+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m OpenCL.Program+compileProg prog = kernelsToCUDA <$> ImpGenKernels.compileProg prog
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -39,9 +39,9 @@ , opsAllocCompilers = mempty } -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program)+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m Imp.Program compileProg prog =- fmap (setDefaultSpace (Imp.Space "device")) <$>+ setDefaultSpace (Imp.Space "device") <$> Futhark.CodeGen.ImpGen.compileProg callKernelOperations (Imp.Space "device") prog opCompiler :: Pattern ExplicitMemory -> Op ExplicitMemory
src/Futhark/CodeGen/ImpGen/Kernels/Base.hs view
@@ -86,7 +86,7 @@ kernelAlloc _ (Pattern _ [mem]) _ _ = compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel." kernelAlloc _ dest _ _ =- compilerBugS $ "Invalid target for in-kernel allocation: " ++ show dest+ error $ "Invalid target for in-kernel allocation: " ++ show dest splitSpace :: (ToExp w, ToExp i, ToExp elems_per_thread) => Pattern ExplicitMemory -> SplitOrdering -> w -> i -> elems_per_thread@@ -97,7 +97,7 @@ elems_per_thread' <- Imp.elements <$> toExp elems_per_thread computeThreadChunkSize o i' elems_per_thread' num_elements (patElemName size) splitSpace pat _ _ _ _ =- compilerBugS $ "Invalid target for splitSpace: " ++ pretty pat+ error $ "Invalid target for splitSpace: " ++ pretty pat compileThreadExp :: ExpCompiler ExplicitMemory Imp.KernelOp compileThreadExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =
src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs view
@@ -42,6 +42,12 @@ then kernelLocalThreadId constants else kernelGlobalThreadId constants +barrierFor :: Lambda ExplicitMemory -> (Bool, Imp.Fence, InKernelGen ())+barrierFor scan_op = (array_scan, fence, sOp $ Imp.Barrier fence)+ where array_scan = not $ all primType $ lambdaReturnType scan_op+ fence | array_scan = Imp.FenceGlobal+ | otherwise = Imp.FenceLocal+ -- | Produce partially scanned intervals; one per workgroup. scanStage1 :: Pattern ExplicitMemory -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace@@ -162,11 +168,7 @@ return (num_threads, elems_per_group, crossesSegment) - where array_scan = not $ all primType $ lambdaReturnType scan_op- fence | array_scan = Imp.FenceGlobal- | otherwise = Imp.FenceLocal- barrier = sOp $ Imp.Barrier fence-+ where (array_scan, fence, barrier) = barrierFor scan_op scanStage2 :: Pattern ExplicitMemory -> VName -> Imp.Exp -> Count NumGroups SubExp -> CrossesSegment -> SegSpace@@ -204,6 +206,8 @@ sComment "threads in bound read carries; others get neutral element" $ sIf in_bounds when_in_bounds when_out_of_bounds + barrier+ groupScan constants crossesSegment' (Imp.vi32 stage1_num_threads) (kernelGroupSize constants) scan_op local_arrs @@ -211,6 +215,8 @@ sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) -> copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids) (Var arr) [localArrayIndex constants t]++ where (_, _, barrier) = barrierFor scan_op scanStage3 :: Pattern ExplicitMemory -> Count NumGroups SubExp -> Count GroupSize SubExp
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -19,7 +19,6 @@ import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Quote.CUDA as CUDAC -import Futhark.Error import qualified Futhark.CodeGen.Backends.GenericC as GenericC import Futhark.CodeGen.Backends.SimpleRepresentation import Futhark.CodeGen.ImpCode.Kernels hiding (Program)@@ -29,24 +28,35 @@ import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) -kernelsToCUDA, kernelsToOpenCL :: ImpKernels.Program- -> Either InternalError ImpOpenCL.Program+kernelsToCUDA, kernelsToOpenCL :: ImpKernels.Program -> ImpOpenCL.Program kernelsToCUDA = translateKernels TargetCUDA kernelsToOpenCL = translateKernels TargetOpenCL -- | Translate a kernels-program to an OpenCL-program. translateKernels :: KernelTarget -> ImpKernels.Program- -> Either InternalError ImpOpenCL.Program-translateKernels target (ImpKernels.Functions funs) = do- (prog', ToOpenCL kernels used_types sizes failures) <-- flip runStateT initialOpenCL $ fmap Functions $ forM funs $ \(fname, fun) ->- (fname,) <$> runReaderT (traverse (onHostOp target) fun) fname- let kernels' = M.map fst kernels+ -> ImpOpenCL.Program+translateKernels target prog =+ let (prog', ToOpenCL kernels used_types sizes failures) =+ flip runState initialOpenCL $ do+ let ImpKernels.Definitions+ (ImpKernels.Constants ps consts)+ (ImpKernels.Functions funs) = prog+ consts' <- runReaderT (traverse (onHostOp target) consts)+ (nameFromString "val")+ funs' <- forM funs $ \(fname, fun) ->+ (fname,) <$> runReaderT (traverse (onHostOp target) fun) fname+ return $ ImpOpenCL.Definitions+ (ImpOpenCL.Constants ps consts')+ (ImpOpenCL.Functions funs')++ kernels' = M.map fst kernels opencl_code = openClCode $ map snd $ M.elems kernels opencl_prelude = pretty $ genPrelude target used_types- return $ ImpOpenCL.Program opencl_code opencl_prelude kernels'- (S.toList used_types) (cleanSizes sizes) failures prog'++ in ImpOpenCL.Program opencl_code opencl_prelude kernels'+ (S.toList used_types) (cleanSizes sizes) failures prog'+ where genPrelude TargetOpenCL = genOpenClPrelude genPrelude TargetCUDA = const genCUDAPrelude @@ -98,7 +108,7 @@ initialOpenCL :: ToOpenCL initialOpenCL = ToOpenCL mempty mempty mempty mempty -type OnKernelM = ReaderT Name (StateT ToOpenCL (Either InternalError))+type OnKernelM = ReaderT Name (State ToOpenCL) addSize :: Name -> SizeClass -> OnKernelM () addSize key sclass =@@ -120,7 +130,7 @@ onKernel target kernel = do failures <- gets clFailures let (kernel_body, cstate) =- GenericC.runCompilerM mempty (inKernelOperations (kernelBody kernel))+ GenericC.runCompilerM (inKernelOperations (kernelBody kernel)) blankNameSource (newKernelState failures) $ GenericC.blockScope $ GenericC.compileCode $ kernelBody kernel@@ -173,14 +183,13 @@ [C.citems| volatile __local bool local_failure; if (failure_is_an_option) {- if (get_local_id(0) == 0) {- local_failure = *global_failure >= 0;+ int failed = *global_failure >= 0;+ if (failed) {+ return; }- barrier(CLK_LOCAL_MEM_FENCE);- if (local_failure) { return; }- } else {- local_failure = false; }+ // All threads write this value - it looks like CUDA has a compiler bug otherwise.+ local_failure = false; barrier(CLK_LOCAL_MEM_FENCE); |])
src/Futhark/CodeGen/ImpGen/OpenCL.hs view
@@ -2,12 +2,11 @@ ( compileProg ) where -import Futhark.Error import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError OpenCL.Program)-compileProg prog = either Left kernelsToOpenCL <$> ImpGenKernels.compileProg prog+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m OpenCL.Program+compileProg prog = kernelsToOpenCL <$> ImpGenKernels.compileProg prog
src/Futhark/CodeGen/ImpGen/Sequential.hs view
@@ -4,17 +4,16 @@ ) where -import Futhark.Error import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen as ImpGen import Futhark.Representation.ExplicitMemory import Futhark.MonadFreshNames -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program)+compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m Imp.Program compileProg = ImpGen.compileProg ops Imp.DefaultSpace where ops = ImpGen.defaultOperations opCompiler opCompiler :: ImpGen.OpCompiler ExplicitMemory Imp.Sequential opCompiler dest (Alloc e space) = ImpGen.compileAlloc dest e space opCompiler _ (Inner _) =- compilerBugS "Cannot handle kernels in sequential code generator."+ error "Cannot handle kernels in sequential code generator."
src/Futhark/CodeGen/SetDefaultSpace.hs view
@@ -5,11 +5,14 @@ import Futhark.CodeGen.ImpCode --- | Set all uses of 'DefaultSpace' in the given functions to another memory space.-setDefaultSpace :: Space -> Functions op -> Functions op-setDefaultSpace space (Functions fundecs) =- Functions [ (fname, setFunctionSpace space func)- | (fname, func) <- fundecs ]+-- | Set all uses of 'DefaultSpace' in the given definitions to another+-- memory space.+setDefaultSpace :: Space -> Definitions op -> Definitions op+setDefaultSpace space (Definitions (Constants ps consts) (Functions fundecs)) =+ Definitions+ (Constants (map (setParamSpace space) ps) (setBodySpace space consts))+ (Functions [ (fname, setFunctionSpace space func)+ | (fname, func) <- fundecs ]) setFunctionSpace :: Space -> Function op -> Function op setFunctionSpace space (Function entry outputs inputs body results args) =
src/Futhark/Doc/Generator.hs view
@@ -18,8 +18,8 @@ import qualified Text.Blaze.Html5.Attributes as A import Data.String (fromString) import Data.Version-import qualified Data.Text.Lazy as LT-import Text.Markdown+import qualified Data.Text as T+import qualified CMarkGFM as GFM import Prelude hiding (abs) @@ -588,7 +588,9 @@ docHtml :: Maybe DocComment -> DocM Html docHtml (Just (DocComment doc loc)) =- markdown def { msAddHeadingId = True } . LT.pack <$> identifierLinks loc doc+ H.preEscapedText .+ GFM.commonmarkToHtml [] [GFM.extAutolink] .+ T.pack <$> identifierLinks loc doc docHtml Nothing = return mempty identifierLinks :: SrcLoc -> String -> DocM String
src/Futhark/Error.hs view
@@ -7,8 +7,7 @@ , externalError , externalErrorS - , InternalError- , internalError+ , InternalError(..) , compilerBug , compilerBugS , compilerLimitation@@ -16,6 +15,7 @@ ) where +import Control.Exception import Control.Monad.Error.Class import qualified Data.Text as T import Futhark.Util.Pretty@@ -48,20 +48,21 @@ -- | An error that is not the users fault, but a bug (or limitation) -- in the compiler. Compiler passes should only ever report this -- error - any problems after the type checker are *our* fault, not--- the users.+-- the users. These are generally thrown as IO exceptions, and caught+-- at the top level. data InternalError = Error ErrorClass T.Text+ deriving (Show) -compilerBug :: MonadError InternalError m => T.Text -> m a-compilerBug = throwError . Error CompilerBug+instance Exception InternalError -compilerLimitation :: MonadError InternalError m => T.Text -> m a-compilerLimitation = throwError . Error CompilerLimitation+compilerBug :: T.Text -> a+compilerBug = throw . Error CompilerBug -internalError :: MonadError CompilerError m => InternalError -> T.Text -> m a-internalError (Error c s) t = throwError $ InternalError s t c+compilerLimitation :: T.Text -> a+compilerLimitation = throw . Error CompilerLimitation -compilerBugS :: MonadError InternalError m => String -> m a+compilerBugS :: String -> a compilerBugS = compilerBug . T.pack -compilerLimitationS :: MonadError InternalError m => String -> m a+compilerLimitationS :: String -> a compilerLimitationS = compilerLimitation . T.pack
src/Futhark/Internalise.hs view
@@ -11,7 +11,6 @@ import Control.Monad.State import Control.Monad.Reader-import Data.Bifunctor (first) import Data.Bitraversable import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -47,8 +46,9 @@ prog_decs <- Defunctorise.transformProg prog prog_decs' <- Monomorphise.transformProg prog_decs prog_decs'' <- Defunctionalise.transformProg prog_decs'- prog' <- I.Prog <$> runInternaliseM always_safe (internaliseValBinds prog_decs'')- I.renameProg prog'+ (consts, funs) <-+ runInternaliseM always_safe (internaliseValBinds prog_decs'')+ I.renameProg $ I.Prog consts funs internaliseValBinds :: [E.ValBind] -> InternaliseM () internaliseValBinds = mapM_ internaliseValBind@@ -66,34 +66,30 @@ Nothing -> return $ nameFromString $ pretty ofname internaliseValBind :: E.ValBind -> InternaliseM ()-internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, retext)) tparams params body _ loc) = do- bindingParams tparams params $ \pcm shapeparams params' -> do- (rettype_bad, rcm) <- internaliseReturnType =<< existentialisedRetExt+internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ loc) = do+ localConstsScope $ bindingParams tparams params $ \shapeparams params' -> do+ rettype_bad <- internaliseReturnType rettype let rettype' = zeroExts rettype_bad - let mkConstParam name = Param name $ I.Prim int32- constparams = map (mkConstParam . snd) $ pcm<>rcm- constnames = map I.paramName constparams- constscope = M.fromList $ zip constnames $ repeat $- FParamInfo $ I.Prim $ IntType Int32-- shapenames = map I.paramName shapeparams- normal_params = map I.paramName constparams ++ shapenames ++- map I.paramName (concat params')+ let shapenames = map I.paramName shapeparams+ normal_params = shapenames ++ map I.paramName (concat params') normal_param_names = namesFromList normal_params fname' <- internaliseFunName fname params - body' <- localScope constscope $ do+ body' <- do msg <- case retdecl of Just dt -> errorMsg . ("Function return value does not match shape of type ":) <$>- typeExpForError rcm dt+ 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') - let free_in_fun = freeIn body' `namesSubtract` normal_param_names+ constants <- allConsts+ let free_in_fun = freeIn body'+ `namesSubtract` normal_param_names+ `namesSubtract` constants used_free_params <- forM (namesToList free_in_fun) $ \v -> do v_t <- lookupType v@@ -102,23 +98,19 @@ let free_shape_params = map (`Param` I.Prim int32) $ concatMap (I.shapeVars . I.arrayShape . I.paramType) used_free_params free_params = nub $ free_shape_params ++ used_free_params- all_params = constparams ++ free_params ++ shapeparams ++ concat params'+ all_params = free_params ++ shapeparams ++ concat params' - addFunction $ I.FunDef Nothing fname' rettype' all_params body'+ let fd = I.FunDef Nothing fname' rettype' all_params body' if null params'- then bindConstant fname (fname',- pcm<>rcm,- applyRetType rettype' constparams,- bindExtSizes rettype retext,- namesFromList retext)- else bindFunction fname (fname',- pcm<>rcm,- map I.paramName free_params,- shapenames,- map declTypeOf $ concat params',- all_params,- applyRetType rettype' all_params)+ then bindConstant fname fd+ else bindFunction fname fd+ (fname',+ map I.paramName free_params,+ shapenames,+ map declTypeOf $ concat params',+ all_params,+ applyRetType rettype' all_params) case entry of Just (Info entry') -> generateEntryPoint entry' fb Nothing -> return ()@@ -129,13 +121,6 @@ -- them from somewhere else. zeroExts ts = generaliseExtTypes ts ts - existentialisedRetExt = do- sizes <- (namesFromList retext<>) <$> topLevelSizes- let onDim (NamedDim v)- | qualLeaf v `nameIn` sizes = AnyDim- onDim d = d- return $ first onDim rettype- allDimsFreshInType :: MonadFreshNames m => E.PatternType -> m E.PatternType allDimsFreshInType = bitraverse onDim pure where onDim (E.NamedDim v) =@@ -166,21 +151,21 @@ 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) = do+generateEntryPoint (E.EntryPoint e_paramts e_rettype) (E.ValBind _ ofname _ (Info (rettype, _)) _ params _ _ loc) = localConstsScope $ do -- We replace all shape annotations, so there should be no constant -- parameters here. params_fresh <- mapM allDimsFreshInPat params let tparams = map (`E.TypeParamDim` noLoc) $ S.toList $ mconcat $ map E.patternDimNames params_fresh- bindingParams tparams params_fresh $ \_ shapeparams params' -> do- (entry_rettype, _) <- internaliseEntryReturnType $ anySizes rettype+ bindingParams tparams params_fresh $ \shapeparams params' -> do+ entry_rettype <- internaliseEntryReturnType $ anySizes rettype let entry' = entryPoint (zip e_paramts params') (e_rettype, entry_rettype) args = map (I.Var . I.paramName) $ concat params' entry_body <- insertStmsM $ do -- Special case the (rare) situation where the entry point is -- not a function.- maybe_const <- internaliseIfConst loc ofname+ maybe_const <- lookupConst ofname vals <- case maybe_const of Just ses -> return ses@@ -190,7 +175,7 @@ mapM (fmap I.arrayDims . subExpType) vals resultBodyM (ctx ++ vals) - addFunction $+ addFunDef $ I.FunDef (Just entry') (baseName ofname) (concat entry_rettype) (shapeparams ++ concat params') entry_body@@ -275,13 +260,13 @@ I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8 internaliseExp _ (E.Var (E.QualName _ name) (Info t) loc) = do- subst <- asks $ M.lookup name . envSubsts+ subst <- lookupSubst name case subst of Just substs -> return substs Nothing -> do -- If this identifier is the name of a constant, we have to turn it -- into a call to the corresponding function.- is_const <- internaliseIfConst loc name+ is_const <- lookupConst name case is_const of Just ses -> return ses Nothing -> (:[]) . I.Var <$> internaliseIdent (E.Ident name (Info t) loc)@@ -334,8 +319,7 @@ letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr | otherwise = do- (arr_t_ext, cm) <- internaliseReturnType $ E.toStruct arr_t- mapM_ (uncurry (internaliseDimConstant loc)) cm+ arr_t_ext <- internaliseReturnType $ E.toStruct arr_t es' <- mapM (internaliseExp "arr_elem") es let typeFromElements =@@ -496,9 +480,8 @@ internaliseExp desc (E.Coerce e (TypeDecl dt (Info et)) _ loc) = do es <- internaliseExp desc e- (ts, cm) <- internaliseReturnType et- mapM_ (uncurry (internaliseDimConstant loc)) cm- dt' <- typeExpForError cm dt+ ts <- internaliseReturnType et+ dt' <- typeExpForError dt forM (zip es ts) $ \(e',t') -> do dims <- arrayDims <$> subExpType e' let parts = ["Value of (core language) shape ("] ++@@ -537,7 +520,7 @@ args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args) let args'' = concatMap tag args' letTupExp' desc $ I.Apply fname args'' [I.Prim rettype]- (I.NotConstFun, Safe, loc, [])+ (Safe, loc, []) | otherwise -> do args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)@@ -619,12 +602,11 @@ i <- newVName "i" bindingParams sparams' [mergepat] $- \mergecm shapepat nested_mergepat ->- bindingLambdaParams [x] (map rowType arr_ts) $ \x_cm x_params -> do- mapM_ (uncurry (internaliseDimConstant loc)) x_cm- mapM_ (uncurry (internaliseDimConstant loc)) mergecm+ \shapepat nested_mergepat ->+ bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do let loopvars = zip x_params arr'- forLoop nested_mergepat shapepat mergeinit $ I.ForLoop i Int32 w loopvars+ forLoop nested_mergepat shapepat mergeinit $+ I.ForLoop i Int32 w loopvars handleForm mergeinit (E.For i num_iterations) = do num_iterations' <- internaliseExp1 "upper_bound" num_iterations@@ -635,14 +617,13 @@ _ -> error "internaliseExp DoLoop: invalid type" bindingParams sparams' [mergepat] $- \mergecm shapepat nested_mergepat -> do- mapM_ (uncurry (internaliseDimConstant loc)) mergecm- forLoop nested_mergepat shapepat mergeinit $ I.ForLoop i' it num_iterations' []+ \shapepat nested_mergepat ->+ forLoop nested_mergepat shapepat mergeinit $+ I.ForLoop i' it num_iterations' [] handleForm mergeinit (E.While cond) =- bindingParams sparams' [mergepat] $ \mergecm shapepat nested_mergepat -> do+ bindingParams sparams' [mergepat] $ \shapepat nested_mergepat -> do mergeinit_ts <- mapM subExpType mergeinit- mapM_ (uncurry (internaliseDimConstant loc)) mergecm let mergepat' = concat nested_mergepat -- We need to insert 'cond' twice - once for the initial -- condition (do we enter the loop at all?), and once with the@@ -750,9 +731,8 @@ letBindNames_ [v'] $ I.BasicOp $ I.SubExp v return $ I.Var v' -internaliseExp _ (E.Constr c es (Info (E.Scalar (E.Sum fs))) loc) = do- ((ts, constr_map), cm) <- internaliseSumType $ M.map (map E.toStruct) fs- mapM_ (uncurry (internaliseDimConstant loc)) cm+internaliseExp _ (E.Constr c es (Info (E.Scalar (E.Sum fs))) _) = do+ (ts, constr_map) <- internaliseSumType $ M.map (map E.toStruct) fs es' <- concat <$> mapM (internaliseExp "payload") es let noExt _ = return $ intConst Int32 0@@ -886,7 +866,7 @@ return ([cmp], [se], ses) compares (E.PatternConstr c (Info (E.Scalar (E.Sum fs))) pats _) (se:ses) = do- ((payload_ts, m), _) <- internaliseSumType $ M.map (map toStruct) fs+ (payload_ts, m) <- internaliseSumType $ M.map (map toStruct) fs case M.lookup c m of Just (i, payload_is) -> do let i' = intConst Int8 $ toInteger i@@ -952,8 +932,7 @@ -> InternaliseM a internalisePat' p ses body loc m = do t <- I.staticShapes <$> mapM I.subExpType ses- stmPattern p t $ \cm pat_names match -> do- mapM_ (uncurry (internaliseDimConstant loc)) cm+ stmPattern p t $ \pat_names match -> do ses' <- match loc ses forM_ (zip pat_names ses') $ \(v,se) -> letBindNames_ [v] $ I.BasicOp $ I.SubExp se@@ -1396,20 +1375,14 @@ internaliseLambda (E.Parens e _) rowtypes = internaliseLambda e rowtypes -internaliseLambda (E.Lambda params body _ (Info (_, rettype)) loc) rowtypes =- bindingLambdaParams params rowtypes $ \pcm params' -> do- (rettype', rcm) <- internaliseReturnType rettype+internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =+ bindingLambdaParams params rowtypes $ \params' -> do+ rettype' <- internaliseReturnType rettype body' <- internaliseBody body- mapM_ (uncurry (internaliseDimConstant loc)) $ pcm<>rcm return (params', body', map I.fromDecl rettype') internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e -internaliseDimConstant :: SrcLoc -> Name -> VName -> InternaliseM ()-internaliseDimConstant loc fname name =- letBind_ (basicPattern [] [I.Ident name $ I.Prim I.int32]) $- I.Apply fname [] [I.Prim I.int32] (I.ConstFun, Safe, loc, mempty)- -- | Some operators and functions are overloaded or otherwise special -- - we detect and treat them here. isOverloadedFunction :: E.QualName VName -> [E.Exp] -> SrcLoc@@ -1749,54 +1722,22 @@ let sa_ws = map (arraySize 0) sa_ts letTupExp' desc $ I.Op $ I.Scatter si_w lam sivs $ zip3 sa_ws (repeat 1) sas --- | Is the name a value constant? If so, create the necessary--- function call and return the corresponding subexpressions.-internaliseIfConst :: SrcLoc -> VName -> InternaliseM (Maybe [SubExp])-internaliseIfConst loc name = do- is_const <- lookupConst name- scope <- askScope- case is_const of- Just (fname, constparams, mk_rettype, bind_ext, _)- | name `M.notMember` scope -> do- (constargs, const_ds, const_ts) <- unzip3 <$> constFunctionArgs loc constparams- safety <- askSafety- case mk_rettype $ zip constargs $ map I.fromDecl const_ts of- Nothing -> error $ "internaliseIfConst: " ++- unwords (pretty name : zipWith (curry pretty) constargs const_ts) ++- " failed"- Just rettype -> do- ses <- fmap (map I.Var) $ letTupExp (baseString name) $- I.Apply fname (zip constargs const_ds) rettype- (I.ConstFun, safety, loc, mempty)- bind_ext ses- return $ Just ses- _ -> return Nothing--constFunctionArgs :: SrcLoc -> ConstParams -> InternaliseM [(SubExp, I.Diet, I.DeclType)]-constFunctionArgs loc = mapM arg- where arg (fname, name) = do- safety <- askSafety- se <- letSubExp (baseString name ++ "_arg") $- I.Apply fname [] [I.Prim I.int32] (I.ConstFun, safety, loc, [])- return (se, I.ObservePrim, I.Prim I.int32)- funcall :: String -> QualName VName -> [SubExp] -> SrcLoc -> InternaliseM ([SubExp], [I.ExtType]) funcall desc (QualName _ fname) args loc = do- (fname', constparams, closure, shapes, value_paramts, fun_params, rettype_fun) <-+ (fname', closure, shapes, value_paramts, fun_params, rettype_fun) <- lookupFunction fname- (constargs, const_ds, _) <- unzip3 <$> constFunctionArgs loc constparams argts <- mapM subExpType args closure_ts <- mapM lookupType closure let shapeargs = argShapes shapes value_paramts argts- diets = const_ds ++ replicate (length closure + length shapeargs) I.ObservePrim +++ diets = replicate (length closure + length shapeargs) I.ObservePrim ++ map I.diet value_paramts constOrShape = const $ I.Prim int32- paramts = map constOrShape constargs ++ closure_ts +++ paramts = closure_ts ++ map constOrShape shapeargs ++ map I.fromDecl value_paramts args' <- ensureArgShapes asserting "function arguments of wrong shape" loc (map I.paramName fun_params)- paramts (constargs ++ map I.Var closure ++ shapeargs ++ args)+ paramts (map I.Var closure ++ shapeargs ++ args) argts' <- mapM subExpType args' case rettype_fun $ zip args' argts' of Nothing -> error $ "Cannot apply " ++ pretty fname ++ " to arguments\n " ++@@ -1805,7 +1746,8 @@ "\nFunction has parameters\n " ++ pretty fun_params Just ts -> do safety <- askSafety- ses <- letTupExp' desc $ I.Apply fname' (zip args' diets) ts (I.NotConstFun, safety, loc, mempty)+ ses <- letTupExp' desc $+ I.Apply fname' (zip args' diets) ts (safety, loc, mempty) return (ses, map I.fromDecl ts) -- Bind existential names defined by an expression, based on the@@ -1815,7 +1757,7 @@ -- language. bindExtSizes :: E.StructType -> [VName] -> [SubExp] -> InternaliseM () bindExtSizes ret retext ses = do- ts <- concat . fst <$>+ ts <- concat <$> internaliseParamTypes mempty (M.fromList $ zip retext retext) [ret] ses_ts <- mapM subExpType ses @@ -1919,49 +1861,49 @@ letSubExp "total_res" $ I.If is_this_one (resultBody [this_one]) (resultBody [next_one]) $ ifCommon [I.Prim int32] -typeExpForError :: ConstParams -> E.TypeExp VName -> InternaliseM [ErrorMsgPart SubExp]-typeExpForError _ (E.TEVar qn _) =+typeExpForError :: E.TypeExp VName -> InternaliseM [ErrorMsgPart SubExp]+typeExpForError (E.TEVar qn _) = return [ErrorString $ pretty qn]-typeExpForError cm (E.TEUnique te _) = ("*":) <$> typeExpForError cm te-typeExpForError cm (E.TEArray te d _) = do- d' <- dimExpForError cm d- te' <- typeExpForError cm te+typeExpForError (E.TEUnique te _) =+ ("*":) <$> typeExpForError te+typeExpForError (E.TEArray te d _) = do+ d' <- dimExpForError d+ te' <- typeExpForError te return $ ["[", d', "]"] ++ te'-typeExpForError cm (E.TETuple tes _) = do- tes' <- mapM (typeExpForError cm) tes+typeExpForError (E.TETuple tes _) = do+ tes' <- mapM typeExpForError tes return $ ["("] ++ intercalate [", "] tes' ++ [")"]-typeExpForError cm (E.TERecord fields _) = do+typeExpForError (E.TERecord fields _) = do fields' <- mapM onField fields return $ ["{"] ++ intercalate [", "] fields' ++ ["}"]- where onField (k, te) = (ErrorString (pretty k ++ ": "):) <$> typeExpForError cm te-typeExpForError cm (E.TEArrow _ t1 t2 _) = do- t1' <- typeExpForError cm t1- t2' <- typeExpForError cm t2+ where onField (k, te) =+ (ErrorString (pretty k ++ ": "):) <$> typeExpForError te+typeExpForError (E.TEArrow _ t1 t2 _) = do+ t1' <- typeExpForError t1+ t2' <- typeExpForError t2 return $ t1' ++ [" -> "] ++ t2'-typeExpForError cm (E.TEApply t arg _) = do- t' <- typeExpForError cm t- arg' <- case arg of TypeArgExpType argt -> typeExpForError cm argt- TypeArgExpDim d _ -> pure <$> dimExpForError cm d+typeExpForError (E.TEApply t arg _) = do+ t' <- typeExpForError t+ arg' <- case arg of TypeArgExpType argt -> typeExpForError argt+ TypeArgExpDim d _ -> pure <$> dimExpForError d return $ t' ++ [" "] ++ arg'-typeExpForError cm (E.TESum cs _) = do+typeExpForError (E.TESum cs _) = do cs' <- mapM (onClause . snd) cs return $ intercalate [" | "] cs' where onClause c = do- c' <- mapM (typeExpForError cm) c+ c' <- mapM typeExpForError c return $ intercalate [" "] c' -dimExpForError :: ConstParams -> E.DimExp VName -> InternaliseM (ErrorMsgPart SubExp)-dimExpForError cm (DimExpNamed d _) = do- substs <- asks $ M.lookup (E.qualLeaf d) . envSubsts- let fname = nameFromString $ pretty (E.qualLeaf d) ++ "f"- d' <- case (substs, lookup fname cm) of- (Just [v], _) -> return v- (_, Just v) -> return $ I.Var v- _ -> return $ I.Var $ E.qualLeaf d+dimExpForError :: E.DimExp VName -> InternaliseM (ErrorMsgPart SubExp)+dimExpForError (DimExpNamed d _) = do+ substs <- lookupSubst $ E.qualLeaf d+ d' <- case substs of+ Just [v] -> return v+ _ -> return $ I.Var $ E.qualLeaf d return $ ErrorInt32 d'-dimExpForError _ (DimExpConst d _) =+dimExpForError (DimExpConst d _) = return $ ErrorString $ pretty d-dimExpForError _ DimExpAny = return ""+dimExpForError DimExpAny = return "" -- A smart constructor that compacts neighbouring literals for easier -- reading in the IR.
src/Futhark/Internalise/Bindings.hs view
@@ -26,14 +26,14 @@ import Futhark.Util bindingParams :: [E.TypeParam] -> [E.Pattern]- -> (ConstParams -> [I.FParam] -> [[I.FParam]] -> InternaliseM a)+ -> ([I.FParam] -> [[I.FParam]] -> InternaliseM a) -> InternaliseM a bindingParams tparams params m = do flattened_params <- mapM flattenPattern params let (params_idents, params_types) = unzip $ concat flattened_params bound = boundInTypes tparams param_names = M.fromList [ (E.identName x, y) | (x,y) <- params_idents ]- (params_ts, cm) <- internaliseParamTypes bound param_names params_types+ params_ts <- internaliseParamTypes bound param_names params_types let num_param_idents = map length flattened_params num_param_ts = map (sum . map length) $ chunks num_param_idents params_ts @@ -49,22 +49,22 @@ shape_subst = M.fromList [ (I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params ] bindingFlatPattern params_idents (concat params_ts') $ \valueparams -> I.localScope (I.scopeOfFParams $ shape_params++concat valueparams) $- substitutingVars shape_subst $ m cm shape_params $ chunks num_param_ts (concat valueparams)+ substitutingVars shape_subst $ m shape_params $ chunks num_param_ts (concat valueparams) bindingLambdaParams :: [E.Pattern] -> [I.Type]- -> (ConstParams -> [I.LParam] -> InternaliseM a)+ -> ([I.LParam] -> InternaliseM a) -> InternaliseM a bindingLambdaParams params ts m = do (params_idents, params_types) <- unzip . concat <$> mapM flattenPattern params let param_names = M.fromList [ (E.identName x, y) | (x,y) <- params_idents ]- (params_ts, cm) <- internaliseParamTypes mempty param_names params_types+ params_ts <- internaliseParamTypes mempty param_names params_types let ascript_substs = lambdaShapeSubstitutions (concat params_ts) ts bindingFlatPattern params_idents ts $ \params' -> local (\env -> env { envSubsts = ascript_substs `M.union` envSubsts env }) $- I.localScope (I.scopeOfLParams $ concat params') $ m cm $ concat params'+ I.localScope (I.scopeOfLParams $ concat params') $ m $ concat params' processFlatPattern :: Show t => [(E.Ident,VName)] -> [t] -> InternaliseM ([[I.Param t]], VarSubstitutions)@@ -95,10 +95,8 @@ internaliseBindee :: (E.Ident, VName) -> InternaliseM [(VName, I.DeclExtType)] internaliseBindee (bindee, name) = do- -- XXX: we gotta be screwing up somehow by ignoring the extra- -- return values. If not, why not?- (tss, _) <- internaliseParamTypes nothing_bound mempty- [flip E.setAliases () $ E.unInfo $ E.identType bindee]+ tss <- internaliseParamTypes nothing_bound mempty+ [flip E.setAliases () $ E.unInfo $ E.identType bindee] case concat tss of [t] -> return [(name, t)] tss' -> forM tss' $ \t -> do@@ -148,15 +146,15 @@ type MatchPattern = SrcLoc -> [I.SubExp] -> InternaliseM [I.SubExp] stmPattern :: E.Pattern -> [I.ExtType]- -> (ConstParams -> [VName] -> MatchPattern -> InternaliseM a)+ -> ([VName] -> MatchPattern -> InternaliseM a) -> InternaliseM a stmPattern pat ts m = do (pat', pat_types) <- unzip <$> flattenPattern pat (ts',_) <- instantiateShapes' ts- (pat_types', cm) <- internaliseParamTypes mempty mempty pat_types+ pat_types' <- internaliseParamTypes mempty mempty pat_types let pat_types'' = map I.fromDecl $ concat pat_types' let addShapeStms l =- m cm (map I.paramName $ concat l) (matchPattern pat_types'')+ m (map I.paramName $ concat l) (matchPattern pat_types'') bindingFlatPattern pat' ts' addShapeStms matchPattern :: [I.ExtType] -> MatchPattern
src/Futhark/Internalise/Monad.hs view
@@ -5,21 +5,23 @@ , throwError , VarSubstitutions , InternaliseEnv (..)- , ConstParams , Closure- , FunInfo, ConstInfo+ , FunInfo , substitutingVars- , addFunction+ , lookupSubst+ , addFunDef , lookupFunction , lookupFunction' , lookupConst- , topLevelSizes+ , allConsts , bindFunction , bindConstant + , localConstsScope+ , asserting , assertingOne @@ -47,26 +49,17 @@ import Futhark.MonadFreshNames import Futhark.Tools -type ConstParams = [(Name,VName)]- -- | Extra parameters to pass when calling this function. This -- corresponds to the closure of a locally defined function. type Closure = [VName] -type FunInfo = (Name, ConstParams, Closure,+type FunInfo = (Name, Closure, [VName], [DeclType], [FParam], [(SubExp,Type)] -> Maybe [DeclExtType]) type FunTable = M.Map VName FunInfo -type ConstInfo = (Name, ConstParams,- [(SubExp,Type)] -> Maybe [DeclExtType],- [SubExp] -> InternaliseM (),- Names)--type ConstTable = M.Map VName ConstInfo- -- | A mapping from external variable names to the corresponding -- internalised subexpressions. type VarSubstitutions = M.Map VName [SubExp]@@ -80,13 +73,20 @@ data InternaliseState = InternaliseState { stateNameSource :: VNameSource , stateFunTable :: FunTable- , stateConstTable :: ConstTable- , stateTopLevelSizes :: Names+ , stateConstSubsts :: VarSubstitutions+ , stateConstScope :: Scope SOACS+ , stateConsts :: Names } -newtype InternaliseResult = InternaliseResult [FunDef SOACS]- deriving (Semigroup, Monoid)+data InternaliseResult = InternaliseResult (Stms SOACS) [FunDef SOACS] +instance Semigroup InternaliseResult where+ InternaliseResult xs1 ys1 <> InternaliseResult xs2 ys2 =+ InternaliseResult (xs1<>xs2) (ys1<>ys2)++instance Monoid InternaliseResult where+ mempty = InternaliseResult mempty mempty+ newtype InternaliseM a = InternaliseM (BinderT SOACS (RWS InternaliseEnv@@ -116,12 +116,12 @@ runInternaliseM :: MonadFreshNames m => Bool -> InternaliseM ()- -> m [FunDef SOACS]+ -> m (Stms SOACS, [FunDef SOACS]) runInternaliseM safe (InternaliseM m) = modifyNameSource $ \src ->- let (_, s, InternaliseResult funs) =+ let ((_, consts), s, InternaliseResult _ funs) = runRWS (runBinderT m mempty) newEnv (newState src)- in (funs, stateNameSource s)+ in ((consts, funs), stateNameSource s) where newEnv = InternaliseEnv { envSubsts = mempty , envDoBoundsChecks = True@@ -130,16 +130,24 @@ newState src = InternaliseState { stateNameSource = src , stateFunTable = mempty- , stateConstTable = mempty- , stateTopLevelSizes = mempty+ , stateConstSubsts = mempty+ , stateConsts = mempty+ , stateConstScope = mempty } substitutingVars :: VarSubstitutions -> InternaliseM a -> InternaliseM a substitutingVars substs = local $ \env -> env { envSubsts = substs <> envSubsts env } +lookupSubst :: VName -> InternaliseM (Maybe [SubExp])+lookupSubst v = do+ env_substs <- asks $ M.lookup v . envSubsts+ const_substs <- gets $ M.lookup v . stateConstSubsts+ return $ env_substs `mplus` const_substs+ -- | Add a function definition to the program being constructed.-addFunction :: FunDef SOACS -> InternaliseM ()-addFunction = InternaliseM . lift . tell . InternaliseResult . pure+addFunDef :: FunDef SOACS -> InternaliseM ()+addFunDef fd =+ InternaliseM $ lift $ tell $ InternaliseResult mempty [fd] lookupFunction' :: VName -> InternaliseM (Maybe FunInfo) lookupFunction' fname = gets $ M.lookup fname . stateFunTable@@ -148,23 +156,33 @@ lookupFunction fname = maybe bad return =<< lookupFunction' fname where bad = error $ "Internalise.lookupFunction: Function '" ++ pretty fname ++ "' not found." -lookupConst :: VName -> InternaliseM (Maybe ConstInfo)-lookupConst fname = gets $ M.lookup fname . stateConstTable+lookupConst :: VName -> InternaliseM (Maybe [SubExp])+lookupConst fname = gets $ M.lookup fname . stateConstSubsts -bindFunction :: VName -> FunInfo -> InternaliseM ()-bindFunction fname info =+allConsts :: InternaliseM Names+allConsts = gets stateConsts++bindFunction :: VName -> FunDef SOACS -> FunInfo -> InternaliseM ()+bindFunction fname fd info = do+ addFunDef fd modify $ \s -> s { stateFunTable = M.insert fname info $ stateFunTable s } -bindConstant :: VName -> ConstInfo -> InternaliseM ()-bindConstant cname info =- modify $ \s -> s { stateConstTable = M.insert cname info $ stateConstTable s }+bindConstant :: VName -> FunDef SOACS -> InternaliseM ()+bindConstant cname fd = do+ let stms = bodyStms $ funDefBody fd+ substs = bodyResult $ funDefBody fd+ const_names = namesFromList $ M.keys $ scopeOf stms+ addStms stms+ modify $ \s ->+ s { stateConstSubsts = M.insert cname substs $ stateConstSubsts s+ , stateConstScope = scopeOf stms <> stateConstScope s+ , stateConsts = const_names <> stateConsts s+ } --- | Size names implicitly created by existential top-level constant--- definitions. These need special treatment because such a thing--- does not exist in the core language.-topLevelSizes :: InternaliseM Names-topLevelSizes = gets $ foldMap sizes . stateConstTable- where sizes (_, _, _, _, x) = x+localConstsScope :: InternaliseM a -> InternaliseM a+localConstsScope m = do+ scope <- gets stateConstScope+ localScope scope m -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list.@@ -186,7 +204,7 @@ newtype TypeEnv = TypeEnv { typeEnvDims :: DimTable } -type TypeState = (Int, ConstParams)+type TypeState = Int newtype InternaliseTypeM a = InternaliseTypeM (ReaderT TypeEnv (StateT TypeState InternaliseM) a)@@ -198,12 +216,9 @@ liftInternaliseM = InternaliseTypeM . lift . lift runInternaliseTypeM :: InternaliseTypeM a- -> InternaliseM (a, ConstParams)-runInternaliseTypeM (InternaliseTypeM m) = do- let new_env = TypeEnv mempty- new_state = (0, mempty)- (x, (_, cm)) <- runStateT (runReaderT m new_env) new_state- return (x, cm)+ -> InternaliseM a+runInternaliseTypeM (InternaliseTypeM m) =+ evalStateT (runReaderT m (TypeEnv mempty)) 0 withDims :: DimTable -> InternaliseTypeM a -> InternaliseTypeM a withDims dtable = local $ \env -> env { typeEnvDims = dtable <> typeEnvDims env }
src/Futhark/Internalise/TypesValues.hs view
@@ -19,7 +19,6 @@ where import Control.Monad.State-import Control.Monad.Reader import Data.List (delete, find, foldl') import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -47,8 +46,7 @@ internaliseParamTypes :: BoundInTypes -> M.Map VName VName -> [E.TypeBase (E.DimDecl VName) ()]- -> InternaliseM ([[I.TypeBase ExtShape Uniqueness]],- ConstParams)+ -> InternaliseM [[I.TypeBase ExtShape Uniqueness]] internaliseParamTypes (BoundInTypes bound) pnames ts = runInternaliseTypeM $ withDims (bound' <> M.map (Free . Var) pnames) $ mapM internaliseTypeM ts@@ -56,17 +54,13 @@ (map (Free . Var) $ S.toList bound)) internaliseReturnType :: E.TypeBase (E.DimDecl VName) ()- -> InternaliseM ([I.TypeBase ExtShape Uniqueness],- ConstParams)-internaliseReturnType t = do- (ts', cm') <- internaliseEntryReturnType t- return (concat ts', cm')+ -> InternaliseM [I.TypeBase ExtShape Uniqueness]+internaliseReturnType = fmap concat . internaliseEntryReturnType -- | As 'internaliseReturnType', but returns components of a top-level -- tuple type piecemeal. internaliseEntryReturnType :: E.TypeBase (E.DimDecl VName) ()- -> InternaliseM ([[I.TypeBase ExtShape Uniqueness]],- ConstParams)+ -> InternaliseM [[I.TypeBase ExtShape Uniqueness]] internaliseEntryReturnType t = do let ts = case E.isTupleRecord t of Just tts | not $ null tts -> tts _ -> [t]@@ -74,12 +68,11 @@ internaliseType :: E.TypeBase (E.DimDecl VName) () -> InternaliseM [I.TypeBase I.ExtShape Uniqueness]-internaliseType =- fmap fst . runInternaliseTypeM . internaliseTypeM+internaliseType = runInternaliseTypeM . internaliseTypeM newId :: InternaliseTypeM Int-newId = do (i,cm) <- get- put (i + 1, cm)+newId = do i <- get+ put $ i + 1 return i internaliseDim :: E.DimDecl VName@@ -90,22 +83,12 @@ E.ConstDim n -> return $ Free $ intConst I.Int32 $ toInteger n E.NamedDim name -> namedDim name where namedDim (E.QualName _ name) = do- subst <- liftInternaliseM $ asks $ M.lookup name . envSubsts+ subst <- liftInternaliseM $ lookupSubst name is_dim <- lookupDim name- is_const <- liftInternaliseM $ lookupConst name - case (is_dim, is_const, subst) of- (Just dim, _, _) -> return dim-- (Nothing, Nothing, Just [v]) -> return $ I.Free v-- (_, Just (fname, _, _, _, _), _) -> do- (i,cm) <- get- case find ((==fname) . fst) cm of- Just (_, known) -> return $ I.Free $ I.Var known- Nothing -> do new <- liftInternaliseM $ newVName $ baseString name- put (i, (fname,new):cm)- return $ I.Free $ I.Var new+ case (is_dim, subst) of+ (Just dim, _) -> return dim+ (Nothing, Just [v]) -> return $ I.Free v _ -> return $ I.Free $ I.Var name internaliseTypeM :: E.StructType@@ -155,9 +138,8 @@ new_ts ++ [t]) internaliseSumType :: M.Map Name [E.StructType]- -> InternaliseM (([I.TypeBase ExtShape Uniqueness],- M.Map Name (Int, [Int])),- ConstParams)+ -> InternaliseM ([I.TypeBase ExtShape Uniqueness],+ M.Map Name (Int, [Int])) internaliseSumType cs = runInternaliseTypeM $ internaliseConstructors <$> traverse (fmap concat . mapM internaliseTypeM) cs
src/Futhark/Optimise/CSE.hs view
@@ -29,6 +29,7 @@ module Futhark.Optimise.CSE ( performCSE , performCSEOnFunDef+ , performCSEOnStms , CSEInOp ) where@@ -40,13 +41,13 @@ import Futhark.Representation.AST import Futhark.Representation.AST.Attributes.Aliases import Futhark.Representation.Aliases- (removeFunDefAliases, Aliases, consumedInStms)+ (removeProgAliases, removeFunDefAliases, removeStmAliases,+ Aliases, consumedInStms) import qualified Futhark.Representation.Kernels.Kernel as Kernel import qualified Futhark.Representation.SOACS.SOAC as SOAC import qualified Futhark.Representation.ExplicitMemory as ExplicitMemory import Futhark.Transform.Substitute import Futhark.Pass-import Futhark.Util (takeLast) -- | Perform CSE on every function in a program. performCSE :: (Attributes lore, CanBeAliased (Op lore),@@ -54,8 +55,14 @@ Bool -> Pass lore lore performCSE cse_arrays = Pass "CSE" "Combine common subexpressions." $- intraproceduralTransformation $- return . removeFunDefAliases . cseInFunDef cse_arrays . analyseFun+ fmap removeProgAliases .+ intraproceduralTransformationWithConsts onConsts onFun .+ aliasAnalysis+ where onConsts stms =+ pure $ fst $+ runReader (cseInStms (consumedInStms stms) (stmsToList stms) (return ()))+ (newCSEState cse_arrays)+ onFun _ = pure . cseInFunDef cse_arrays -- | Perform CSE on a single function. performCSEOnFunDef :: (Attributes lore, CanBeAliased (Op lore),@@ -64,6 +71,17 @@ performCSEOnFunDef cse_arrays = removeFunDefAliases . cseInFunDef cse_arrays . analyseFun +-- | Perform CSE on some statements.+performCSEOnStms :: (Attributes lore, CanBeAliased (Op lore),+ CSEInOp (OpWithAliases (Op lore))) =>+ Bool -> Stms lore -> Stms lore+performCSEOnStms cse_arrays =+ fmap removeStmAliases . f . fst . analyseStms mempty+ where f stms =+ fst $ runReader (cseInStms (consumedInStms stms)+ (stmsToList stms) (return ()))+ (newCSEState cse_arrays)+ cseInFunDef :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => Bool -> FunDef lore -> FunDef lore cseInFunDef cse_arrays fundec =@@ -76,12 +94,13 @@ cseInBody :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => [Diet] -> Body lore -> CSEM lore (Body lore)-cseInBody ds (Body bodyattr bnds res) =- cseInStms (res_cons <> consumedInStms bnds res) (stmsToList bnds) $ do+cseInBody ds (Body bodyattr bnds res) = do+ (bnds', res') <-+ cseInStms (res_cons <> consumedInStms bnds) (stmsToList bnds) $ do CSEState (_, nsubsts) _ <- ask- return $ Body bodyattr mempty $ substituteNames nsubsts res- where res_cons = mconcat $ zipWith consumeResult ds $- takeLast (length ds) res+ return $ substituteNames nsubsts res+ return $ Body bodyattr bnds' res'+ where res_cons = mconcat $ zipWith consumeResult ds res consumeResult Consume se = freeIn se consumeResult _ _ = mempty @@ -93,14 +112,15 @@ cseInStms :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => Names -> [Stm lore]- -> CSEM lore (Body lore)- -> CSEM lore (Body lore)-cseInStms _ [] m = m+ -> CSEM lore a+ -> CSEM lore (Stms lore, a)+cseInStms _ [] m = do a <- m+ return (mempty, a) cseInStms consumed (bnd:bnds) m = cseInStm consumed bnd $ \bnd' -> do- Body bodyattr bnds' es <- cseInStms consumed bnds m+ (bnds', a) <- cseInStms consumed bnds m bnd'' <- mapM nestedCSE bnd'- return $ Body bodyattr (stmsFromList bnd''<>bnds') es+ return (stmsFromList bnd''<>bnds', a) where nestedCSE bnd' = do let ds = map patElemDiet $ patternValueElements $ stmPattern bnd' e <- mapExpM (cse ds) $ stmExp bnd'
src/Futhark/Optimise/DoubleBuffer.hs view
@@ -46,15 +46,14 @@ doubleBuffer = Pass { passName = "Double buffer" , passDescription = "Perform double buffering for merge parameters of sequential loops."- , passFunction = intraproceduralTransformation optimiseFunDef+ , passFunction = intraproceduralTransformation optimise }+ where optimise scope stms = modifyNameSource $ \src ->+ let m = runDoubleBufferM $ localScope scope $+ fmap stmsFromList $ optimiseStms $ stmsToList stms+ in runState (runReaderT m env) src -optimiseFunDef :: FunDef ExplicitMemory -> PassM (FunDef ExplicitMemory)-optimiseFunDef fundec = modifyNameSource $ \src ->- let m = runDoubleBufferM $ inScopeOf fundec $ optimiseBody $ funDefBody fundec- (body', src') = runState (runReaderT m env) src- in (fundec { funDefBody = body' }, src')- where env = Env mempty doNotTouchLoop+ env = Env mempty doNotTouchLoop doNotTouchLoop ctx val body = return (mempty, ctx, val, body) data Env = Env { envScope :: Scope ExplicitMemory
src/Futhark/Optimise/Fusion.hs view
@@ -29,12 +29,12 @@ import Futhark.Pass data VarEntry = IsArray VName (NameInfo SOACS) Names SOAC.Input- | IsNotArray VName (NameInfo SOACS)+ | IsNotArray (NameInfo SOACS) varEntryType :: VarEntry -> NameInfo SOACS varEntryType (IsArray _ attr _ _) = attr-varEntryType (IsNotArray _ attr) =+varEntryType (IsNotArray attr) = attr varEntryAliases :: VarEntry -> Names@@ -82,7 +82,7 @@ env { varsInScope = M.insert name entry $ varsInScope env } where entry = case t of Array {} -> IsArray name (LetInfo t) aliases' $ SOAC.identInput $ Ident name t- _ -> IsNotArray name $ LetInfo t+ _ -> IsNotArray $ LetInfo t expand = maybe mempty varEntryAliases . flip M.lookup (varsInScope env) aliases' = aliases <> mconcat (map expand $ namesToList aliases) @@ -176,32 +176,39 @@ fuseSOACs = Pass { passName = "Fuse SOACs" , passDescription = "Perform higher-order optimisation, i.e., fusion."- , passFunction = simplifySOACS <=< renameProg <=< intraproceduralTransformation fuseFun+ , passFunction = \prog ->+ simplifySOACS =<< renameProg =<<+ intraproceduralTransformationWithConsts+ (fuseConsts (freeIn (progFuns prog))) fuseFun prog } -fuseFun :: FunDef SOACS -> PassM (FunDef SOACS)-fuseFun fun = do+fuseConsts :: Names -> Stms SOACS -> PassM (Stms SOACS)+fuseConsts used_consts consts =+ fuseStms mempty consts $ map Var $ namesToList used_consts++fuseFun :: Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS)+fuseFun consts fun = do+ stms <- fuseStms (scopeOf consts <> scopeOfFParams (funDefParams fun))+ (bodyStms $ funDefBody fun)+ (bodyResult $ funDefBody fun)+ let body = (funDefBody fun) { bodyStms = stms }+ return fun { funDefBody = body }++fuseStms :: Scope SOACS -> Stms SOACS -> Result -> PassM (Stms SOACS)+fuseStms scope stms res = do let env = FusionGEnv { soacs = M.empty- , varsInScope = M.empty+ , varsInScope = mempty , fusedRes = mempty } k <- cleanFusionResult <$>- liftEitherM (runFusionGatherM (fusionGatherFun fun) env)+ liftEitherM (runFusionGatherM+ (binding scope' $ fusionGatherStms mempty (stmsToList stms) res)+ env) if not $ rsucc k- then return fun- else liftEitherM $ runFusionGatherM (fuseInFun k fun) env--fusionGatherFun :: FunDef SOACS -> FusionGM FusedRes-fusionGatherFun fundec =- bindingParams (funDefParams fundec) $- fusionGatherBody mempty $ funDefBody fundec--fuseInFun :: FusedRes -> FunDef SOACS -> FusionGM (FunDef SOACS)-fuseInFun res fundec = do- body' <- bindingParams (funDefParams fundec) $- bindRes res $- fuseInBody $ funDefBody fundec- return $ fundec { funDefBody = body' }+ then return stms+ else liftEitherM $ runFusionGatherM (binding scope' $ bindRes k $ fuseInStms stms) env+ where scope' = map toBind $ M.toList scope+ toBind (k, t) = (Ident k $ typeOf t, mempty) --------------------------------------------------- ---------------------------------------------------@@ -750,14 +757,18 @@ ------------------------------------------------------------- ------------------------------------------------------------- -fuseInBody :: Body -> FusionGM Body--fuseInBody (Body _ stms res)- | Let pat aux e:bnds <- stmsToList stms = do- body' <- bindingPat pat $ fuseInBody $ mkBody (stmsFromList bnds) res+fuseInStms :: Stms SOACS -> FusionGM (Stms SOACS)+fuseInStms stms+ | Just (Let pat aux e, stms') <- stmsHead stms = do+ stms'' <- bindingPat pat $ fuseInStms stms' soac_bnds <- replaceSOAC pat aux e- return $ insertStms soac_bnds body'- | otherwise = return $ Body () mempty res+ pure $ soac_bnds <> stms''+ | otherwise =+ pure mempty++fuseInBody :: Body -> FusionGM Body+fuseInBody (Body _ stms res) =+ Body () <$> fuseInStms stms <*> pure res fuseInExp :: Exp -> FusionGM Exp
src/Futhark/Optimise/InPlaceLowering.hs view
@@ -84,16 +84,25 @@ inPlaceLowering = Pass "In-place lowering" "Lower in-place updates into loops" $ fmap removeProgAliases .- intraproceduralTransformation optimiseFunDef .+ intraproceduralTransformationWithConsts optimiseConsts optimiseFunDef . aliasAnalysis -optimiseFunDef :: MonadFreshNames m => FunDef (Aliases Kernels)+optimiseConsts :: MonadFreshNames m => Stms (Aliases Kernels)+ -> m (Stms (Aliases Kernels))+optimiseConsts stms =+ modifyNameSource $ runForwardingM lowerUpdateKernels onKernelOp $+ stmsFromList <$> optimiseStms (stmsToList stms) (pure ())++optimiseFunDef :: MonadFreshNames m =>+ Stms (Aliases Kernels) -> FunDef (Aliases Kernels) -> m (FunDef (Aliases Kernels))-optimiseFunDef fundec =+optimiseFunDef consts fundec = modifyNameSource $ runForwardingM lowerUpdateKernels onKernelOp $- bindingFParams (funDefParams fundec) $ do+ descend (stmsToList consts) $ bindingFParams (funDefParams fundec) $ do body <- optimiseBody $ funDefBody fundec return $ fundec { funDefBody = body }+ where descend [] m = m+ descend (stm:stms) m = bindingStm stm $ descend stms m type Constraints lore = (Bindable lore, CanBeAliased (Op lore))
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -3,7 +3,6 @@ -- then removing those that have become dead. module Futhark.Optimise.InliningDeadFun ( inlineFunctions- , inlineConstants , removeDeadFunctions ) where@@ -16,33 +15,34 @@ import qualified Data.Set as S import Futhark.Representation.SOACS-import Futhark.Representation.SOACS.Simplify (simpleSOACS, simplifyFun)+import Futhark.Representation.SOACS.Simplify+ (simpleSOACS, simplifyFun, simplifyConsts) import Futhark.Optimise.CSE-import Futhark.Transform.CopyPropagate (copyPropagateInFun)+import Futhark.Optimise.Simplify.Lore (addScopeWisdom)+import Futhark.Transform.CopyPropagate+ (copyPropagateInProg, copyPropagateInFun)+import qualified Futhark.Analysis.SymbolTable as ST import Futhark.Transform.Rename import Futhark.Analysis.CallGraph import Futhark.Binder import Futhark.Pass aggInlineFunctions :: MonadFreshNames m =>- CallGraph -> [FunDef SOACS] -> m [FunDef SOACS]+ CallGraph+ -> (Stms SOACS, [FunDef SOACS])+ -> m (Stms SOACS, [FunDef SOACS]) aggInlineFunctions cg =- fmap (filter keep) . recurse 0 . filter isFunInCallGraph- where isFunInCallGraph fundec =- isJust $ M.lookup (funDefName fundec) cg-- constfuns =- S.fromList $ M.keys $ M.filter (==ConstFun) $ mconcat $ M.elems cg-- fdmap fds =+ fmap (fmap (filter keep)) . recurse 0 . addVtable+ where fdmap fds = M.fromList $ zip (map funDefName fds) fds - noCallsTo :: (Name -> Bool) -> FunDef SOACS -> Bool- noCallsTo interesting fundec =- case M.lookup (funDefName fundec) cg of- Just calls -> not $ any interesting (M.keys calls)- _ -> False+ addVtable (consts, funs) =+ (ST.fromScope (addScopeWisdom (scopeOf consts)),+ consts, funs) + noCallsTo which fundec =+ not $ any (`S.member` which) $ allCalledBy (funDefName fundec) cg+ -- The inverse rate at which we perform full simplification -- after inlining. For the other steps we just do copy -- propagation. The rate here has been determined@@ -55,70 +55,76 @@ -- because it is more efficient to shrink the program as soon -- as possible, rather than wait until it has balooned after -- full inlining.- recurse i funs = do+ recurse i (vtable, consts, funs) = do let remaining = S.fromList $ map funDefName funs (to_be_inlined, maybe_inline_in) =- partition (noCallsTo (`S.member` remaining)) funs+ partition (noCallsTo remaining) funs (not_to_inline_in, to_inline_in) = partition (noCallsTo- (`elem` map funDefName to_be_inlined))+ (S.fromList $ map funDefName to_be_inlined)) maybe_inline_in (not_actually_inlined, to_be_inlined') = partition keep to_be_inlined if null to_be_inlined- then return funs- else do let simplify fd- | i `rem` simplifyRate == 0 ||- funDefName fd `S.member` constfuns =- copyPropagateInFun simpleSOACS =<<- performCSEOnFunDef True <$> simplifyFun fd- | otherwise =- copyPropagateInFun simpleSOACS fd+ then return (consts, funs)+ else do - let onFun = simplify <=< renameFun .- doInlineInCaller (fdmap to_be_inlined') False- to_inline_in' <- mapM onFun to_inline_in- (not_actually_inlined<>) <$>- recurse (i+1) (not_to_inline_in <> to_inline_in')+ (vtable', consts') <-+ if any ((`calledByConsts` cg) . funDefName) to_be_inlined'+ then simplifyConsts =<<+ performCSEOnStms True <$>+ inlineInStms (fdmap to_be_inlined') consts+ else pure (vtable, consts) - keep fd =- isJust (funDefEntryPoint fd)- || callsRecursive fd- || expensiveConstant fd+ let simplifyFun' fd+ | i `rem` simplifyRate == 0 =+ copyPropagateInFun simpleSOACS vtable' =<<+ performCSEOnFunDef True <$>+ simplifyFun vtable' fd+ | otherwise =+ copyPropagateInFun simpleSOACS vtable' fd - expensiveConstant fd =- funDefName fd `S.member` constfuns &&- not (null (bodyStms (funDefBody fd)))+ let onFun = simplifyFun' <=<+ inlineInFunDef (fdmap to_be_inlined')+ to_inline_in' <- mapM onFun to_inline_in+ fmap (not_actually_inlined<>) <$>+ recurse (i+1)+ (vtable', consts', not_to_inline_in <> to_inline_in') - callsRecursive fd = maybe False (any recursive . M.keys) $- M.lookup (funDefName fd) cg+ keep fd =+ isJust (funDefEntryPoint fd) || callsRecursive fd - recursive fname = case M.lookup fname cg of- Just calls -> fname `M.member` calls- Nothing -> False+ callsRecursive fd = any recursive $ allCalledBy (funDefName fd) cg+ recursive fname = calls fname fname cg --- | @doInlineInCaller constf fdmap caller@ inlines in @calleer@--- the functions in @fdmap@ that are called as @constf@. At this--- point the preconditions are that if @fdmap@ is not empty, and,--- more importantly, the functions in @fdmap@ do not call any--- other functions. Further extensions that transform a tail-recursive--- function to a do or while loop, should do the transformation first--- and then do the inlining.-doInlineInCaller :: M.Map Name (FunDef SOACS) -> Bool -> FunDef SOACS- -> FunDef SOACS-doInlineInCaller fdmap always_reshape (FunDef entry name rtp args body) =- let body' = inlineInBody fdmap always_reshape body- in FunDef entry name rtp args body'+-- | @inlineInFunDef constf fdmap caller@ inlines in @calleer@ the+-- functions in @fdmap@ that are called as @constf@. At this point the+-- preconditions are that if @fdmap@ is not empty, and, more+-- importantly, the functions in @fdmap@ do not call any other+-- functions.+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 -inlineFunction :: Bool- -> Pattern+inlineFunction :: MonadFreshNames m =>+ Pattern -> StmAux attr -> [(SubExp, Diet)]- -> (ConstFun, Safety, SrcLoc, [SrcLoc])+ -> (Safety, SrcLoc, [SrcLoc]) -> FunDef SOACS- -> [Stm]-inlineFunction always_reshape pat aux args (_,safety,loc,locs) fun =- param_stms <> body_stms <> res_stms+ -> m [Stm]+inlineFunction pat aux args (safety,loc,locs) fun = do+ Body _ stms res <-+ renameBody $ mkBody+ (stmsFromList param_stms <> stmsFromList body_stms)+ (bodyResult (funDefBody fun))+ let res_stms =+ certify (stmAuxCerts aux) <$>+ zipWith (reshapeIfNecessary (patternNames pat))+ (patternIdents pat) res+ pure $ stmsToList stms <> res_stms where param_names = map paramName $ funDefParams fun @@ -131,14 +137,9 @@ addLocations safety (filter notNoLoc (loc:locs)) $ bodyStms $ funDefBody fun - res_stms =- certify (stmAuxCerts aux) <$>- zipWith (reshapeIfNecessary (patternNames pat))- (patternIdents pat) (bodyResult $ funDefBody fun)- reshapeIfNecessary dim_names ident se | t@Array{} <- identType ident,- always_reshape || any (`elem` dim_names) (subExpVars $ arrayDims t),+ any (`elem` dim_names) (subExpVars $ arrayDims t), Var v <- se = mkLet [] [ident] $ shapeCoerce (arrayDims t) v | otherwise =@@ -146,39 +147,46 @@ notNoLoc = (/=NoLoc) . locOf -inlineInBody :: M.Map Name (FunDef SOACS) -> Bool -> Body -> Body-inlineInBody fdmap always_reshape = onBody+inlineInStms :: MonadFreshNames m =>+ M.Map Name (FunDef SOACS) -> Stms SOACS -> m (Stms SOACS)+inlineInStms fdmap stms =+ bodyStms <$> inlineInBody fdmap (mkBody stms [])++inlineInBody :: MonadFreshNames m =>+ M.Map Name (FunDef SOACS) -> Body -> m Body+inlineInBody fdmap = onBody where inline (Let pat aux (Apply fname args _ what) : rest) | Just fd <- M.lookup fname fdmap =- inlineFunction always_reshape pat aux args what fd- <> inline rest+ (<>) <$> inlineFunction pat aux args what fd <*> inline rest+ inline (stm : rest) =- onStm stm : inline rest- inline [] = mempty+ (:) <$> onStm stm <*> inline rest+ inline [] =+ pure mempty onBody (Body attr stms res) =- Body attr (stmsFromList $ inline (stmsToList stms)) res+ Body attr . stmsFromList <$> inline (stmsToList stms) <*> pure res onStm (Let pat aux e) =- Let pat aux $ mapExp inliner e+ Let pat aux <$> mapExpM inliner e inliner =- identityMapper { mapOnBody = const $ return . onBody- , mapOnOp = return . onSOAC+ identityMapper { mapOnBody = const onBody+ , mapOnOp = onSOAC } onSOAC =- runIdentity . mapSOACM identitySOACMapper- { mapOnSOACLambda = return . onLambda }+ mapSOACM identitySOACMapper+ { mapOnSOACLambda = onLambda } onLambda (Lambda params body ret) =- Lambda params (onBody body) ret+ Lambda params <$> onBody body <*> pure ret addLocations :: Safety -> [SrcLoc] -> Stms SOACS -> Stms SOACS addLocations caller_safety more_locs = fmap onStm where onStm stm = stm { stmExp = onExp $ stmExp stm }- onExp (Apply fname args t (constf, safety, loc,locs)) =- Apply fname args t (constf, min caller_safety safety, loc,locs++more_locs)+ onExp (Apply fname args t (safety, loc,locs)) =+ Apply fname args t (min caller_safety safety, loc,locs++more_locs) onExp (BasicOp (Assert cond desc (loc,locs))) = case caller_safety of Safe -> BasicOp $ Assert cond desc (loc,locs++more_locs)@@ -200,57 +208,10 @@ , passDescription = "Inline and remove resulting dead functions." , passFunction = pass }- where pass prog = do+ where pass prog@(Prog consts funs) = do let cg = buildCallGraph prog- Prog <$> aggInlineFunctions cg (progFuns prog)--aggInlineConstants :: [FunDef SOACS] -> [FunDef SOACS]-aggInlineConstants orig_fds =- map inlineInEntry $ filter (isJust . funDefEntryPoint) orig_fds- where fdmap = M.fromList $ zip (map funDefName orig_fds) orig_fds-- inlineInEntry fd =- fd { funDefBody = constsInBody mempty $ funDefBody fd }-- constsInBody prev body =- body { bodyStms = constsInStms prev (bodyStms body) }-- constsInStms prev stms =- case stmsHead stms of- Nothing -> mempty-- Just (Let pat aux (Apply fname args _ prop),- stms')- | Just ses <- M.lookup fname prev ->- stmsFromList- (zipWith reshapeResult (patternIdents pat) ses)- <> constsInStms prev stms'-- | Just fd <- M.lookup fname fdmap ->- let stm_stms =- inlineFunction True pat aux args prop fd- prev' =- M.insert fname (map Var $ patternNames pat) prev- in constsInStms prev' $ stmsFromList stm_stms <> stms'-- Just (stm, stms') ->- oneStm stm <> constsInStms prev stms'-- reshapeResult ident se- | t@Array{} <- identType ident,- Var v <- se =- mkLet [] [ident] $ shapeCoerce (arrayDims t) v- | otherwise =- mkLet [] [ident] $ BasicOp $ SubExp se---- | Inline 'ConstFun' functions and remove the resulting dead functions.-inlineConstants :: Pass SOACS SOACS-inlineConstants =- Pass { passName = "Inline constants"- , passDescription = "Inline and remove dead constants."- , passFunction = pass- }- where pass prog = return $ Prog $ aggInlineConstants $ progFuns prog+ (consts', funs') <- aggInlineFunctions cg (consts, funs)+ copyPropagateInProg simpleSOACS $ Prog consts' funs' -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program.@@ -262,6 +223,6 @@ } where pass prog = let cg = buildCallGraph prog- live_funs = filter (isFunInCallGraph cg) (progFuns prog)- in Prog live_funs- isFunInCallGraph cg fundec = isJust $ M.lookup (funDefName fundec) cg+ live_funs = filter ((`isFunInCallGraph` cg) . funDefName) $+ progFuns prog+ in prog { progFuns = live_funs }
src/Futhark/Optimise/Simplify.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-} module Futhark.Optimise.Simplify ( simplifyProg , simplifySomething@@ -18,10 +19,12 @@ ) where +import Data.Bifunctor (second) import Futhark.Representation.AST import Futhark.MonadFreshNames import qualified Futhark.Optimise.Simplify.Engine as Engine import qualified Futhark.Analysis.SymbolTable as ST+import qualified Futhark.Analysis.UsageTable as UT import Futhark.Optimise.Simplify.Rule import Futhark.Optimise.Simplify.Lore import Futhark.Pass@@ -35,22 +38,48 @@ -> Engine.HoistBlockers lore -> Prog lore -> PassM (Prog lore)-simplifyProg simpl rules blockers =- intraproceduralTransformation $ simplifyFun simpl rules blockers+simplifyProg simpl rules blockers (Prog consts funs) = do+ (consts_vtable, consts') <-+ simplifyConsts (UT.usages $ foldMap (freeIn . funDefBody) funs)+ (mempty, consts) + funs' <- parPass (simplifyFun' consts_vtable) funs+ let funs_uses = UT.usages $ foldMap (freeIn . funDefBody) funs'++ (_, consts'') <- simplifyConsts funs_uses (mempty, consts')++ return $ Prog consts'' funs'++ where simplifyFun' consts_vtable =+ simplifySomething+ (Engine.localVtable (consts_vtable<>) . Engine.simplifyFun)+ removeFunDefWisdom+ simpl rules blockers mempty++ simplifyConsts uses =+ simplifySomething (onConsts uses . snd)+ (second (removeStmWisdom<$>))+ simpl rules blockers mempty++ onConsts uses consts' = do+ (_, consts'') <-+ Engine.simplifyStms consts' (pure ((), mempty))+ (consts''', _) <-+ Engine.hoistStms rules (Engine.isFalse False) mempty uses consts''+ return (ST.insertStms consts''' mempty, consts''')+ -- | Run a simplification operation to convergence.-simplifySomething :: (MonadFreshNames m, HasScope lore m,- Engine.SimplifiableLore lore) =>+simplifySomething :: (MonadFreshNames m, Engine.SimplifiableLore lore) => (a -> Engine.SimpleM lore b) -> (b -> a) -> Engine.SimpleOps lore -> RuleBook (Wise lore) -> Engine.HoistBlockers lore+ -> ST.SymbolTable (Wise lore) -> a -> m a-simplifySomething f g simpl rules blockers x = do- scope <- askScope- let f' x' = Engine.localVtable (ST.fromScope (addScopeWisdom scope)<>) $ f x'+simplifySomething f g simpl rules blockers vtable x = do+ let f' x' = Engine.localVtable (vtable<>) $ f x' loopUntilConvergence env simpl f' g x where env = Engine.emptyEnv rules blockers @@ -62,33 +91,38 @@ Engine.SimpleOps lore -> RuleBook (Engine.Wise lore) -> Engine.HoistBlockers lore+ -> ST.SymbolTable (Wise lore) -> FunDef lore -> m (FunDef lore)-simplifyFun simpl rules blockers =- loopUntilConvergence env simpl Engine.simplifyFun removeFunDefWisdom- where env = Engine.emptyEnv rules blockers+simplifyFun = simplifySomething Engine.simplifyFun removeFunDefWisdom -- | Simplify just a single 'Lambda'.-simplifyLambda :: (MonadFreshNames m, HasScope lore m, Engine.SimplifiableLore lore) =>+simplifyLambda :: (MonadFreshNames m, HasScope lore m,+ Engine.SimplifiableLore lore) => Engine.SimpleOps lore -> RuleBook (Engine.Wise lore) -> Engine.HoistBlockers lore -> Lambda lore -> [Maybe VName] -> m (Lambda lore)-simplifyLambda simpl rules blockers orig_lam args =- simplifySomething f removeLambdaWisdom simpl rules blockers orig_lam+simplifyLambda simpl rules blockers orig_lam args = do+ vtable <- ST.fromScope . addScopeWisdom <$> askScope+ simplifySomething f removeLambdaWisdom simpl rules blockers vtable orig_lam where f lam' = Engine.simplifyLambdaNoHoisting lam' args -- | Simplify a list of 'Stm's.-simplifyStms :: (MonadFreshNames m, HasScope lore m, Engine.SimplifiableLore lore) =>+simplifyStms :: (MonadFreshNames m, Engine.SimplifiableLore lore) => Engine.SimpleOps lore -> RuleBook (Engine.Wise lore) -> Engine.HoistBlockers lore+ -> Scope lore -> Stms lore- -> m (Stms lore)-simplifyStms = simplifySomething f g- where f stms = fmap snd $ Engine.simplifyStms stms $ return ((), mempty)- g = fmap removeStmWisdom+ -> m (ST.SymbolTable (Wise lore), Stms lore)+simplifyStms simpl rules blockers scope =+ simplifySomething f g simpl rules blockers vtable . (mempty,)+ where vtable = ST.fromScope $ addScopeWisdom scope+ f (_, stms) =+ Engine.simplifyStms stms ((,mempty) <$> Engine.askVtable)+ g = second $ fmap removeStmWisdom loopUntilConvergence :: (MonadFreshNames m, Engine.SimplifiableLore lore) => Engine.Env lore
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -54,6 +54,7 @@ , simplifyBody , SimplifiedBody + , hoistStms , blockIf , module Futhark.Optimise.Simplify.Lore@@ -89,7 +90,8 @@ } noExtraHoistBlockers :: HoistBlockers lore-noExtraHoistBlockers = HoistBlockers neverBlocks neverBlocks neverBlocks (const mempty) (const False)+noExtraHoistBlockers =+ HoistBlockers neverBlocks neverBlocks neverBlocks (const mempty) (const False) data Env lore = Env { envRules :: RuleBook (Wise lore) , envHoistBlockers :: HoistBlockers lore@@ -133,7 +135,8 @@ protectHoistedOpS' _ _ _ = Nothing newtype SimpleM lore a =- SimpleM (ReaderT (SimpleOps lore, Env lore) (State (VNameSource, Bool, Certificates)) a)+ SimpleM (ReaderT (SimpleOps lore, Env lore)+ (State (VNameSource, Bool, Certificates)) a) deriving (Applicative, Functor, Monad, MonadReader (SimpleOps lore, Env lore), MonadState (VNameSource, Bool, Certificates))@@ -207,7 +210,8 @@ foldr ST.insertLParam vtable params bindArrayLParams :: SimplifiableLore lore =>- [(LParam (Wise lore),Maybe VName)] -> SimpleM lore a -> SimpleM lore a+ [(LParam (Wise lore),Maybe VName)] -> SimpleM lore a+ -> SimpleM lore a bindArrayLParams params = localVtable $ \vtable -> foldr (uncurry ST.insertArrayLParam) vtable params@@ -349,7 +353,8 @@ case res of Nothing -- Nothing to optimise - see if hoistable. | block vtable' uses' stm ->- return (expandUsage vtable' uses' stm `UT.without` provides stm,+ return (expandUsage vtable' uses' stm+ `UT.without` provides stm, Left stm : stms) | otherwise -> return (expandUsage vtable' uses' stm, Right stm : stms)@@ -426,11 +431,6 @@ (blocked, hoisted) <- hoistStms rules block vtable usages stms return ((blocked, x), hoisted) -insertAllStms :: SimplifiableLore lore =>- SimpleM lore (SimplifiedBody lore Result)- -> SimpleM lore (Body (Wise lore))-insertAllStms = uncurry constructBody . fst <=< blockIf (isFalse False)- hasFree :: Attributes lore => Names -> BlockPred lore hasFree ks _ _ need = ks `namesIntersect` freeIn need @@ -459,8 +459,6 @@ cheapExp (If _ tbranch fbranch _) = all cheapStm (bodyStms tbranch) && all cheapStm (bodyStms fbranch) cheapExp (Op op) = cheapOp op-cheapExp (Apply _ _ _ (constf, _, _, _)) =- constf == ConstFun cheapExp _ = True -- Used to be False, but -- let's try it out. @@ -475,7 +473,9 @@ SubExp -> IfSort -> SimplifiedBody lore Result -> SimplifiedBody lore Result- -> SimpleM lore (Body (Wise lore), Body (Wise lore), Stms (Wise lore))+ -> SimpleM lore (Body (Wise lore),+ Body (Wise lore),+ Stms (Wise lore)) hoistCommon cond ifsort ((res1, usages1), stms1) ((res2, usages2), stms2) = do is_alloc_fun <- asksEngineEnv $ isAllocation . envHoistBlockers getArrSz_fun <- asksEngineEnv $ getArraySizes . envHoistBlockers@@ -507,7 +507,6 @@ -- possible. isNotHoistableBnd _ _ _ (Let _ _ (BasicOp ArrayLit{})) = False isNotHoistableBnd _ _ _ (Let _ _ (BasicOp SubExp{})) = False- isNotHoistableBnd _ _ _ (Let _ _ (Apply _ _ _ (ConstFun, _, _, _))) = False isNotHoistableBnd nms _ _ stm = not (hasPatName nms stm) block = branch_blocker `orIf`@@ -741,7 +740,8 @@ instance (Simplifiable a, Simplifiable b) => Simplifiable (a, b) where simplify (x,y) = (,) <$> simplify x <*> simplify y -instance (Simplifiable a, Simplifiable b, Simplifiable c) => Simplifiable (a, b, c) where+instance (Simplifiable a, Simplifiable b, Simplifiable c) =>+ Simplifiable (a, b, c) where simplify (x,y,z) = (,,) <$> simplify x <*> simplify y <*> simplify z -- Convenient for Scatter.@@ -864,9 +864,18 @@ Just (Var idd', _) -> return [idd'] _ -> return [idd] -simplifyFun :: SimplifiableLore lore => FunDef lore -> SimpleM lore (FunDef (Wise lore))++insertAllStms :: SimplifiableLore lore =>+ SimpleM lore (SimplifiedBody lore Result)+ -> SimpleM lore (Body (Wise lore))+insertAllStms = uncurry constructBody . fst <=< blockIf (isFalse False)+++simplifyFun :: SimplifiableLore lore =>+ FunDef lore -> SimpleM lore (FunDef (Wise lore)) simplifyFun (FunDef entry fname rettype params body) = do rettype' <- simplify rettype+ params' <- mapM (simplifyParam simplify) params let ds = map diet (retTypeValues rettype') body' <- bindFParams params $ insertAllStms $ simplifyBody ds body- return $ FunDef entry fname rettype' params body'+ return $ FunDef entry fname rettype' params' body'
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -365,8 +365,17 @@ FCmpLe{} -> True CmpLlt -> False CmpLle -> True+ simplifyCmpOp _ _ (CmpOp cmp (Constant v1) (Constant v2)) = constRes =<< BoolValue <$> doCmpOp cmp v1 v2++simplifyCmpOp look _ (CmpOp CmpEq{} (Constant (IntValue x)) (Var v))+ | Just (BasicOp (ConvOp BToI{} b), cs) <- look v =+ case valueIntegral x :: Int of+ 1 -> Just (SubExp b, cs)+ 0 -> Just (UnOp Not b, cs)+ _ -> Just (SubExp (Constant (BoolValue False)), cs)+ simplifyCmpOp _ _ _ = Nothing simplifyBinOp :: SimpleRule lore
src/Futhark/Optimise/Sink.hs view
@@ -52,7 +52,6 @@ import qualified Futhark.Analysis.Alias as Alias import qualified Futhark.Analysis.Range as Range import qualified Futhark.Analysis.SymbolTable as ST-import Futhark.MonadFreshNames import Futhark.Representation.Aliases import Futhark.Representation.Ranges import Futhark.Representation.Kernels@@ -175,13 +174,16 @@ let (stms', sunk) = optimiseStms vtable sinking stms $ freeIn res in (KernelBody attr stms' res, sunk) -optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels)-optimiseFunDef fundef = do- let fundef' = Range.analyseFun $ Alias.analyseFun fundef- vtable = ST.insertFParams (funDefParams fundef') mempty- (body, _) = optimiseBody vtable mempty $ funDefBody fundef'- return fundef { funDefBody = removeBodyAliases $ removeBodyRanges body }- sink :: Pass Kernels Kernels sink = Pass "sink" "move memory loads closer to their uses" $- intraproceduralTransformation optimiseFunDef+ fmap (removeProgAliases . removeProgRanges) .+ intraproceduralTransformationWithConsts onConsts onFun .+ Range.rangeAnalysis . Alias.aliasAnalysis+ where onFun _ fd = do+ let vtable = ST.insertFParams (funDefParams fd) mempty+ (body, _) = optimiseBody vtable mempty $ funDefBody fd+ return fd { funDefBody = body }++ onConsts consts =+ pure $ fst $ optimiseStms mempty mempty consts $+ namesFromList $ M.keys $ scopeOf consts
src/Futhark/Optimise/TileLoops.hs view
@@ -22,7 +22,8 @@ tileLoops :: Pass Kernels Kernels tileLoops = Pass "tile loops" "Tile stream loops inside kernels" $- fmap Prog . mapM optimiseFunDef . progFuns+ \(Prog consts funs) ->+ Prog consts <$> mapM optimiseFunDef funs optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels) optimiseFunDef fundec = do
src/Futhark/Optimise/Unstream.hs view
@@ -16,21 +16,20 @@ unstream :: Pass Kernels Kernels unstream = Pass "unstream" "sequentialise remaining SOACs" $- intraproceduralTransformation optimiseFunDef--optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels)-optimiseFunDef fundec = do- body' <- modifyNameSource $ runState $- runReaderT m (scopeOfFParams (funDefParams fundec))- return fundec { funDefBody = body' }- where m = optimiseBody $ funDefBody fundec+ intraproceduralTransformation optimise+ where optimise scope stms =+ modifyNameSource $ runState $ runReaderT (optimiseStms stms) scope type UnstreamM = ReaderT (Scope Kernels) (State VNameSource) +optimiseStms :: Stms Kernels -> UnstreamM (Stms Kernels)+optimiseStms stms =+ localScope (scopeOf stms) $+ stmsFromList . concat <$> mapM optimiseStm (stmsToList stms)+ optimiseBody :: Body Kernels -> UnstreamM (Body Kernels) optimiseBody (Body () stms res) =- localScope (scopeOf stms) $- Body () <$> (stmsFromList . concat <$> mapM optimiseStm (stmsToList stms)) <*> pure res+ Body () <$> optimiseStms stms <*> pure res optimiseKernelBody :: KernelBody Kernels -> UnstreamM (KernelBody Kernels) optimiseKernelBody (KernelBody () stms res) =
src/Futhark/Pass.hs view
@@ -9,11 +9,12 @@ , liftEitherM , Pass (..) , passLongOption+ , parPass , intraproceduralTransformation+ , intraproceduralTransformationWithConsts ) where import Control.Monad.Writer.Strict-import Control.Monad.Except hiding (liftEither) import Control.Monad.State.Strict import Control.Parallel.Strategies import Data.Char@@ -27,9 +28,8 @@ import Futhark.MonadFreshNames -- | The monad in which passes execute.-newtype PassM a = PassM (ExceptT InternalError (WriterT Log (State VNameSource)) a)- deriving (Functor, Applicative, Monad,- MonadError InternalError)+newtype PassM a = PassM (WriterT Log (State VNameSource) a)+ deriving (Functor, Applicative, Monad) instance MonadLogger PassM where addLog = PassM . tell@@ -41,9 +41,8 @@ -- | Execute a 'PassM' action, yielding logging information and either -- an error text or a result. runPassM :: MonadFreshNames m =>- PassM a -> m (Either InternalError a, Log)-runPassM (PassM m) = modifyNameSource $ \src ->- runState (runWriterT $ runExceptT m) src+ PassM a -> m (a, Log)+runPassM (PassM m) = modifyNameSource $ runState (runWriterT m) -- | Turn an 'Either' computation into a 'PassM'. If the 'Either' is -- 'Left', the result is a 'CompilerBug'.@@ -76,17 +75,37 @@ where spaceToDash ' ' = '-' spaceToDash c = c -intraproceduralTransformation :: (FunDef fromlore -> PassM (FunDef tolore))- -> Prog fromlore -> PassM (Prog tolore)-intraproceduralTransformation ft prog =- either onError onSuccess <=< modifyNameSource $ \src ->- case partitionEithers $ parMap rpar (onFunction src) (progFuns prog) of- ([], rs) -> let (funs, logs, srcs) = unzip3 rs- in (Right (Prog funs, mconcat logs), mconcat srcs)- ((err,log,src'):_, _) -> (Left (err, log), src')- where onFunction src f = case runState (runPassM (ft f)) src of- ((Left x, log), src') -> Left (x, log, src')- ((Right x, log), src') -> Right (x, log, src')+-- | Apply a 'PassM' operation in parallel to multiple elements,+-- joining together the name sources and logs, and propagating any+-- error properly.+parPass :: (a -> PassM b) -> [a] -> PassM [b]+parPass f as = do+ (x, log) <- modifyNameSource $ \src ->+ let (bs, logs, srcs) = unzip3 $ parMap rpar (f' src) as+ in ((bs, mconcat logs), mconcat srcs) - onError (err, log) = addLog log >> throwError err- onSuccess (x, log) = addLog log >> return x+ addLog log+ return x++ where f' src a =+ let ((x', log), src') = runState (runPassM (f a)) src+ in (x', log, src')++intraproceduralTransformationWithConsts :: (Stms fromlore -> PassM (Stms tolore))+ -> (Stms tolore -> FunDef fromlore -> PassM (FunDef tolore))+ -> Prog fromlore -> PassM (Prog tolore)+intraproceduralTransformationWithConsts ct ft (Prog consts funs) = do+ consts' <- ct consts+ funs' <- parPass (ft consts') funs+ return $ Prog consts' funs'++intraproceduralTransformation :: (Scope lore -> Stms lore -> PassM (Stms lore))+ -> Prog lore+ -> PassM (Prog lore)+intraproceduralTransformation f =+ intraproceduralTransformationWithConsts (f mempty) f'+ where f' consts fd = do+ stms <- f+ (scopeOf consts<>scopeOfFParams (funDefParams fd))+ (bodyStms $ funDefBody fd)+ return fd { funDefBody = (funDefBody fd) { bodyStms = stms } }
src/Futhark/Pass/ExpandAllocations.hs view
@@ -36,19 +36,23 @@ expandAllocations :: Pass ExplicitMemory ExplicitMemory expandAllocations = Pass "expand allocations" "Expand allocations" $- fmap Prog . mapM transformFunDef . progFuns+ \(Prog consts funs) -> do+ consts' <-+ modifyNameSource $ runState $ runReaderT (transformStms consts) mempty+ Prog consts' <$> mapM (transformFunDef $ scopeOf consts') funs -- Cannot use intraproceduralTransformation because it might create -- duplicate size keys (which are not fixed by renamer, and size -- keys must currently be globally unique). -type ExpandM = ExceptT InternalError (ReaderT (Scope ExplicitMemory) (State VNameSource))+type ExpandM = ReaderT (Scope ExplicitMemory) (State VNameSource) -transformFunDef :: FunDef ExplicitMemory -> PassM (FunDef ExplicitMemory)-transformFunDef fundec = do- body' <- either throwError return <=< modifyNameSource $- runState $ runReaderT (runExceptT m) mempty+transformFunDef :: Scope ExplicitMemory -> FunDef ExplicitMemory+ -> PassM (FunDef ExplicitMemory)+transformFunDef scope fundec = do+ body' <- modifyNameSource $ runState $ runReaderT m mempty return fundec { funDefBody = body' }- where m = inScopeOf fundec $ transformBody $ funDefBody fundec+ where m = localScope scope $ inScopeOf fundec $+ transformBody $ funDefBody fundec transformBody :: Body ExplicitMemory -> ExpandM (Body ExplicitMemory) transformBody (Body () stms res) = Body () <$> transformStms stms <*> pure res@@ -292,7 +296,8 @@ sliceKernelSizes num_threads variant_sizes kspace kstms -- Note the recursive call to expand allocations inside the newly -- produced kernels.- slice_stms_tmp <- ExplicitMemory.simplifyStms =<< explicitAllocationsInStms slice_stms+ (_, slice_stms_tmp) <-+ ExplicitMemory.simplifyStms =<< explicitAllocationsInStms slice_stms slice_stms' <- transformStms slice_stms_tmp let variant_allocs' :: [(VName, (SubExp, SubExp, Space))]
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -509,7 +509,9 @@ explicitAllocations :: Pass Kernels ExplicitMemory explicitAllocations = Pass "explicit allocations" "Transform program to explicit memory representation" $- intraproceduralTransformation allocInFun+ intraproceduralTransformationWithConsts onStms allocInFun+ where onStms stms =+ runAllocM handleHostOp kernelExpHints $ allocInStms stms pure explicitAllocationsInStms :: (MonadFreshNames m, HasScope ExplicitMemory m) => Stms Kernels -> m (Stms ExplicitMemory)@@ -532,9 +534,10 @@ startOfFreeIDRange :: [TypeBase ExtShape u] -> Int startOfFreeIDRange = S.size . shapeContext -allocInFun :: MonadFreshNames m => FunDef Kernels -> m (FunDef ExplicitMemory)-allocInFun (FunDef entry fname rettype params fbody) =- runAllocM handleHostOp kernelExpHints $+allocInFun :: MonadFreshNames m =>+ Stms ExplicitMemory -> FunDef Kernels -> m (FunDef ExplicitMemory)+allocInFun consts (FunDef entry fname rettype params fbody) =+ runAllocM handleHostOp kernelExpHints $ inScopeOf consts $ allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do fbody' <- insertStmsM $ allocInFunBody (map (const $ Just DefaultSpace) rettype) fbody
src/Futhark/Pass/ExtractKernels.hs view
@@ -189,9 +189,15 @@ extractKernels = Pass { passName = "extract kernels" , passDescription = "Perform kernel extraction"- , passFunction = fmap Prog . mapM transformFunDef . progFuns+ , passFunction = transformProg } +transformProg :: Prog SOACS -> PassM (Prog Out.Kernels)+transformProg (Prog consts funs) = do+ consts' <- runDistribM $ transformStms mempty $ stmsToList consts+ funs' <- mapM (transformFunDef $ scopeOf consts') funs+ return $ Prog consts' funs'+ -- In order to generate more stable threshold names, we keep track of -- the numbers used for thresholds separately from the ordinary name -- source,@@ -219,9 +225,10 @@ return x transformFunDef :: (MonadFreshNames m, MonadLogger m) =>- FunDef SOACS -> m (Out.FunDef Out.Kernels)-transformFunDef (FunDef entry name rettype params body) = runDistribM $ do- body' <- localScope (scopeOfFParams params) $+ Scope Out.Kernels -> FunDef SOACS+ -> m (Out.FunDef Out.Kernels)+transformFunDef scope (FunDef entry name rettype params body) = runDistribM $ do+ body' <- localScope (scope <> scopeOfFParams params) $ transformBody mempty body return $ FunDef entry name rettype params body' @@ -367,7 +374,7 @@ | 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_ (certifying cs do_irwim)) types transformStms path $ stmsToList bnds transformStm path (Let pat (StmAux cs _) (Op (Screma w form arrs)))
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -252,8 +252,8 @@ types <- asksScope scopeForSOACs stream_stms <- snd <$> runBinderT (sequentialStreamWholeArray pat w accs lam arrs) types- stream_stms' <-- runReaderT (copyPropagateInStms simpleSOACS stream_stms) types+ (_, stream_stms') <-+ runReaderT (copyPropagateInStms simpleSOACS types stream_stms) types onStms acc $ stmsToList (fmap (certify cs) stream_stms') ++ stms onStms acc (stm:stms) =
src/Futhark/Pass/FirstOrderTransform.hs view
@@ -2,8 +2,8 @@ ( firstOrderTransform ) where -import Futhark.Transform.FirstOrderTransform (transformFunDef)-import Futhark.Representation.SOACS (SOACS)+import Futhark.Transform.FirstOrderTransform (transformFunDef, transformStms)+import Futhark.Representation.SOACS (SOACS, scopeOf) import Futhark.Representation.Kernels (Kernels) import Futhark.Pass @@ -12,4 +12,5 @@ Pass "first order transform" "Transform all second-order array combinators to for-loops." $- intraproceduralTransformation transformFunDef+ intraproceduralTransformationWithConsts+ transformStms (transformFunDef . scopeOf)
src/Futhark/Pass/KernelBabysitting.hs view
@@ -26,21 +26,20 @@ babysitKernels :: Pass Kernels Kernels babysitKernels = Pass "babysit kernels" "Transpose kernel input arrays for better performance." $- intraproceduralTransformation transformFunDef--transformFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels)-transformFunDef fundec = do- (body', _) <- modifyNameSource $ runState (runBinderT m M.empty)- return fundec { funDefBody = body' }- where m = inScopeOf fundec $- transformBody mempty $ funDefBody fundec+ intraproceduralTransformation onStms+ where onStms scope stms = do+ let m = localScope scope $ transformStms mempty stms+ fmap fst $ modifyNameSource $ runState (runBinderT m M.empty) type BabysitM = Binder Kernels +transformStms :: ExpMap -> Stms Kernels -> BabysitM (Stms Kernels)+transformStms expmap stms = collectStms_ $ foldM_ transformStm expmap stms+ transformBody :: ExpMap -> Body Kernels -> BabysitM (Body Kernels)-transformBody expmap (Body () bnds res) = insertStmsM $ do- foldM_ transformStm expmap bnds- return $ resultBody res+transformBody expmap (Body () stms res) = do+ stms' <- transformStms expmap stms+ return $ Body () stms' res -- | Map from variable names to defining expression. We use this to -- hackily determine whether something is transposed or otherwise
src/Futhark/Passes.hs view
@@ -37,9 +37,6 @@ , inlineFunctions , simplifySOACS , performCSE True- , inlineConstants- , simplifySOACS- , performCSE True , simplifySOACS -- We run fusion twice , fuseSOACs
src/Futhark/Pipeline.hs view
@@ -108,7 +108,7 @@ -> FutharkM (Prog tolore) runPasses = unPipeline -onePass :: (Checkable fromlore, Checkable tolore) =>+onePass :: Checkable tolore => Pass fromlore tolore -> Pipeline fromlore tolore onePass pass = Pipeline perform where perform cfg prog = do@@ -132,13 +132,11 @@ throwError $ InternalError msg (prettyText prog) CompilerBug where msg = "Type error after pass '" <> T.pack (passName pass) <> "':\n" <> T.pack err -runPass :: PrettyLore fromlore =>- Pass fromlore tolore+runPass :: Pass fromlore tolore -> Prog fromlore -> FutharkM (Prog tolore) runPass pass prog = do- (res, logged) <- runPassM (passFunction pass prog)+ (prog', logged) <- runPassM (passFunction pass prog) verb <- asks $ (>=VeryVerbose) . futharkVerbose when verb $ addLog logged- case res of Left err -> internalError err $ prettyText prog- Right x -> return x+ return prog'
src/Futhark/Pkg/Info.hs view
@@ -18,13 +18,13 @@ ) where -import Control.Exception import Control.Monad.IO.Class import Data.Maybe import Data.IORef import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Encoding as T import Data.List (foldl', intersperse) import qualified System.FilePath.Posix as Posix@@ -34,17 +34,26 @@ import qualified Codec.Archive.Zip as Zip import Data.Time (UTCTime, UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import System.Process.ByteString (readProcessWithExitCode)-import Network.HTTP.Client hiding (path)-import Network.HTTP.Simple import Futhark.Pkg.Types import Futhark.Util.Log import Futhark.Util (maybeHead) --- | Catch 'HttpException's and turn them into an ordinary return--- value.-httpMayThrow :: IO a -> IO (Either HttpException a)-httpMayThrow m = (Right <$> m) `catch` (pure . Left)+-- | Download URL via shelling out to @curl@.+curl :: String -> IO (Either String BS.ByteString)+curl url = do+ (code, out, err) <-+ -- The -L option follows HTTP redirects.+ liftIO $ readProcessWithExitCode "curl" ["-L", url] mempty+ case code of+ ExitFailure 127 ->+ return $ Left $+ "'" <> unwords ["curl", "-L", url] <> "' failed (program not found?)."+ ExitFailure _ -> do+ liftIO $ BS.hPutStr stderr err+ return $ Left $ "'" <> unwords ["curl", "-L", url] <> "' failed."+ ExitSuccess ->+ return $ Right out -- | The manifest is stored as a monadic action, because we want to -- fetch them on-demand. It would be a waste to fetch it information@@ -97,19 +106,15 @@ T.Text -> m Zip.Archive downloadZipball url = do logMsg $ "Downloading " <> T.unpack url- r <- liftIO $ parseRequest $ T.unpack url let bad = fail . (("When downloading " <> T.unpack url <> ": ")<>)- http <- liftIO $ httpMayThrow $ httpLBS r+ http <- liftIO $ curl $ T.unpack url case http of- Left e -> bad $ "got network error:\n" ++ show e- Right r' ->- case getResponseStatusCode r' of- 200 ->- case Zip.toArchiveOrFail $ getResponseBody r' of- Left e -> bad $ show e- Right a -> return a- x -> bad $ "got HTTP status " ++ show x+ Left e -> bad e+ Right r ->+ case Zip.toArchiveOrFail $ LBS.fromStrict r of+ Left e -> bad $ show e+ Right a -> return a -- | Information about a package. The name of the package is stored -- separately.@@ -177,38 +182,35 @@ T.Text -> T.Text -> T.Text -> T.Text -> GetManifest m ghglRevGetManifest url owner repo tag = GetManifest $ do logMsg $ "Downloading package manifest from " <> url- r <- liftIO $ parseRequest $ T.unpack url let path = T.unpack $ owner <> "/" <> repo <> "@" <> tag <> "/" <> T.pack futharkPkg msg = (("When reading " <> path <> ": ")<>)- http <- liftIO $ httpMayThrow $ httpBS r+ http <- liftIO $ curl $ T.unpack url case http of- Left e -> fail $ msg $ "got network error:\n" ++ show e+ Left e -> fail e Right r' ->- case getResponseStatusCode r' of- 200 ->- case T.decodeUtf8' $ getResponseBody r' of- Left e -> fail $ msg $ show e- Right s ->- case parsePkgManifest path s of- Left e -> fail $ msg $ errorBundlePretty e- Right pm -> return pm- x -> fail $ msg $ "got HTTP status " ++ show x+ case T.decodeUtf8' r' of+ Left e -> fail $ msg $ show e+ Right s ->+ case parsePkgManifest path s of+ Left e -> fail $ msg $ errorBundlePretty e+ Right pm -> return pm ghglLookupCommit :: (MonadIO m, MonadLogger m, MonadFail m) =>- T.Text -> T.Text+ T.Text -> T.Text -> (T.Text -> T.Text) -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> m (PkgRevInfo m)-ghglLookupCommit archive_url manifest_url owner repo d ref hash = do+ghglLookupCommit archive_url manifest_url mk_zip_dir owner repo d ref hash = do gd <- memoiseGetManifest $ ghglRevGetManifest manifest_url owner repo ref- let dir = Posix.addTrailingPathSeparator $ T.unpack repo <> "-" <> T.unpack d+ let dir = Posix.addTrailingPathSeparator $ T.unpack $ mk_zip_dir d time <- liftIO getCurrentTime -- FIXME return $ PkgRevInfo archive_url dir hash gd time ghglPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) =>- T.Text -> (T.Text -> T.Text) -> (T.Text -> T.Text)+ T.Text+ -> (T.Text -> T.Text) -> (T.Text -> T.Text) -> (T.Text -> T.Text) -> T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m))-ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions = do+ghglPkgInfo repo_url mk_archive_url mk_manifest_url mk_zip_dir owner repo versions = do logMsg $ "Retrieving list of tags from " <> repo_url remote_lines <- T.lines . T.decodeUtf8 <$> gitCmd ["ls-remote", T.unpack repo_url] @@ -219,7 +221,8 @@ rev_info <- M.fromList . catMaybes <$> mapM revInfo remote_lines return $ Right $ PkgInfo rev_info $ \r ->- ghglLookupCommit (mk_archive_url (def r)) (mk_manifest_url (def r))+ ghglLookupCommit+ (mk_archive_url (def r)) (mk_manifest_url (def r)) mk_zip_dir owner repo (def r) (def r) (def r) where isHeadRef l | [hash, "HEAD"] <- T.words l = Just hash@@ -231,7 +234,8 @@ "v" `T.isPrefixOf` t, Right v <- semver $ T.drop 1 t, _svMajor v `elem` versions = do- pinfo <- ghglLookupCommit (mk_archive_url t) (mk_manifest_url t)+ pinfo <- ghglLookupCommit+ (mk_archive_url t) (mk_manifest_url t) mk_zip_dir owner repo (prettySemVer v) t hash return $ Just (v, pinfo) | otherwise = return Nothing@@ -239,23 +243,29 @@ ghPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m)) ghPkgInfo owner repo versions =- ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions+ ghglPkgInfo repo_url mk_archive_url mk_manifest_url mk_zip_dir+ owner repo versions where repo_url = "https://github.com/" <> owner <> "/" <> repo mk_archive_url r = repo_url <> "/archive/" <> r <> ".zip" mk_manifest_url r = "https://raw.githubusercontent.com/" <> owner <> "/" <> repo <> "/" <> r <> "/" <> T.pack futharkPkg+ mk_zip_dir r = repo <> "-" <> r glPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m)) glPkgInfo owner repo versions =- ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions+ ghglPkgInfo repo_url mk_archive_url mk_manifest_url mk_zip_dir+ owner repo versions where base_url = "https://gitlab.com/" <> owner <> "/" <> repo repo_url = base_url <> ".git" mk_archive_url r = base_url <> "/-/archive/" <> r <> "/" <> repo <> "-" <> r <> ".zip" mk_manifest_url r = base_url <> "/raw/" <> r <> "/" <> T.pack futharkPkg+ mk_zip_dir r+ | Right _ <- semver r = repo <> "-v" <> r+ | otherwise = repo <> "-" <> r -- | A package registry is a mapping from package paths to information -- about the package. It is unlikely that any given registry is
src/Futhark/Representation/AST/Attributes.hs view
@@ -107,8 +107,8 @@ safeBasicOp _ = False safeExp (DoLoop _ _ _ body) = safeBody body-safeExp (Apply fname _ _ (constf, _, _, _)) =- isBuiltInFunction fname || constf == ConstFun+safeExp (Apply fname _ _ _) =+ isBuiltInFunction fname safeExp (If _ tbranch fbranch _) = all (safeExp . stmExp) (bodyStms tbranch) && all (safeExp . stmExp) (bodyStms fbranch)
src/Futhark/Representation/AST/Attributes/Names.hs view
@@ -173,6 +173,17 @@ FreeIn (FParamAttr lore), FreeIn (LParamAttr lore), FreeIn (LetAttr lore),+ FreeIn (RetType lore),+ FreeIn (Op lore)) => FreeIn (FunDef lore) where+ freeIn' (FunDef _ _ rettype params body) =+ fvBind (namesFromList $ map paramName params) $+ freeIn' rettype <> freeIn' params <> freeIn' body++instance (FreeAttr (ExpAttr lore),+ FreeAttr (BodyAttr lore),+ FreeIn (FParamAttr lore),+ FreeIn (LParamAttr lore),+ FreeIn (LetAttr lore), FreeIn (Op lore)) => FreeIn (Lambda lore) where freeIn' (Lambda params body rettype) = fvBind (namesFromList $ map paramName params) $
src/Futhark/Representation/AST/Pretty.hs view
@@ -160,6 +160,7 @@ DoLoop{} -> True Op{} -> True If{} -> True+ Apply{} -> True BasicOp ArrayLit{} -> False BasicOp Assert{} -> True _ -> cs /= mempty@@ -220,12 +221,10 @@ maybeNest b | null $ bodyStms b = ppr b | otherwise = nestedBlock "{" "}" $ ppr b ppr (BasicOp op) = ppr op- ppr (Apply fname args _ (constf, safety, _, _)) =- text (nameToString fname) <> constf' <> safety' <> apply (map (align . pprArg) args)+ ppr (Apply fname args _ (safety, _, _)) =+ text (nameToString fname) <> safety' <> apply (map (align . pprArg) args) where pprArg (arg, Consume) = text "*" <> ppr arg pprArg (arg, _) = ppr arg- constf' = case constf of ConstFun -> text "<constant>"- NotConstFun -> mempty safety' = case safety of Unsafe -> text "<unsafe>" Safe -> mempty ppr (Op op) = ppr op@@ -254,21 +253,22 @@ ppr (Lambda params body rettype) = annot (mapMaybe ppAnnot params) $ text "fn" <+> ppTuple' rettype <+/>- parens (commasep (map ppr params)) <+>+ align (parens (commasep (map ppr params))) <+> text "=>" </> indent 2 (ppr body) instance PrettyLore lore => Pretty (FunDef lore) where ppr (FunDef entry name rettype fparams body) = annot (mapMaybe ppAnnot fparams) $- text fun <+> ppTuple' rettype <+>- text (nameToString name) <//>+ text fun <+> ppTuple' rettype <+/>+ text (nameToString name) <+> apply (map ppr fparams) <+> equals <+> nestedBlock "{" "}" (ppr body) where fun | isJust entry = "entry" | otherwise = "fun" instance PrettyLore lore => Pretty (Prog lore) where- ppr = stack . punctuate line . map ppr . progFuns+ ppr (Prog consts funs) =+ stack $ punctuate line $ ppr consts : map ppr funs instance Pretty d => Pretty (DimChange d) where ppr (DimCoercion se) = text "~" <> ppr se
src/Futhark/Representation/AST/Syntax.hs view
@@ -43,7 +43,6 @@ , LoopForm (..) , IfAttr (..) , IfSort (..)- , ConstFun (..) , Safety (..) , LambdaT(..) , Lambda@@ -275,7 +274,7 @@ = BasicOp (BasicOp lore) -- ^ A simple (non-recursive) operation. - | Apply Name [(SubExp, Diet)] [RetType lore] (ConstFun, Safety, SrcLoc, [SrcLoc])+ | Apply Name [(SubExp, Diet)] [RetType lore] (Safety, SrcLoc, [SrcLoc]) | If SubExp (BodyT lore) (BodyT lore) (IfAttr (BranchType lore)) @@ -289,10 +288,6 @@ deriving instance Annotations lore => Show (ExpT lore) deriving instance Annotations lore => Ord (ExpT lore) --- | Does this function call actually represent a reference to a--- run-time constant? This has implications for inlining.-data ConstFun = ConstFun | NotConstFun deriving (Eq, Ord, Show)- -- | 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@@ -377,5 +372,14 @@ deriving (Eq, Show, Ord) -- | An entire Futhark program.-newtype Prog lore = Prog { progFuns :: [FunDef lore] }- deriving (Eq, Ord, Show)+data Prog lore = Prog+ { progConsts :: Stms lore+ -- ^ Top-level constants that are computed at program startup, and+ -- which are in scope inside all functions.++ , progFuns :: [FunDef lore]+ -- ^ The functions comprising the program. All funtions are also+ -- available in scope in the definitions of the constants, so be+ -- careful not to introduce circular dependencies (not currently+ -- checked).+ } deriving (Eq, Ord, Show)
src/Futhark/Representation/Aliases.hs view
@@ -27,7 +27,6 @@ , removeProgAliases , removeFunDefAliases , removeExpAliases- , removeBodyAliases , removeStmAliases , removeLambdaAliases , removePatternAliases@@ -214,10 +213,6 @@ Exp (Aliases lore) -> Exp lore removeExpAliases = runIdentity . rephraseExp removeAliases -removeBodyAliases :: CanBeAliased (Op lore) =>- Body (Aliases lore) -> Body lore-removeBodyAliases = runIdentity . rephraseBody removeAliases- removeStmAliases :: CanBeAliased (Op lore) => Stm (Aliases lore) -> Stm lore removeStmAliases = runIdentity . rephraseStm removeAliases@@ -312,9 +307,10 @@ names <> mconcat (map look $ namesToList names) where look k = M.findWithDefault mempty k aliasmap --- | Everything consumed in the given bindings and result (even transitively).-consumedInStms :: Aliased lore => Stms lore -> [SubExp] -> Names-consumedInStms bnds res = snd $ mkStmsAliases bnds res+-- | Everything consumed in the given statements and result (even+-- transitively).+consumedInStms :: Aliased lore => Stms lore -> Names+consumedInStms = snd . flip mkStmsAliases [] type AliasesAndConsumed = (M.Map VName Names, Names)
src/Futhark/Representation/ExplicitMemory/Simplify.hs view
@@ -43,9 +43,12 @@ blockAllocs _ _ _ = False simplifyStms :: (HasScope ExplicitMemory m, MonadFreshNames m) =>- Stms ExplicitMemory -> m (Stms ExplicitMemory)-simplifyStms =+ Stms ExplicitMemory -> m (ST.SymbolTable (Wise ExplicitMemory),+ Stms ExplicitMemory)+simplifyStms stms = do+ scope <- askScope Simplify.simplifyStms simpleExplicitMemory callKernelRules blockers+ scope stms isResultAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore isResultAlloc _ usage (Let (AST.Pattern [] [bindee]) _ (Op Alloc{})) =
src/Futhark/Representation/Ranges.hs view
@@ -21,6 +21,7 @@ , mkPatternRanges , mkBodyRanges -- * Removing ranges+ , removeProgRanges , removeExpRanges , removeBodyRanges , removeStmRanges@@ -106,6 +107,10 @@ , rephraseBranchType = return , rephraseOp = return . removeOpRanges }++removeProgRanges :: CanBeRanged (Op lore) =>+ Prog (Ranges lore) -> Prog lore+removeProgRanges = runIdentity . rephraseProg removeRanges removeExpRanges :: CanBeRanged (Op lore) => Exp (Ranges lore) -> Exp lore
src/Futhark/Representation/SOACS/Simplify.hs view
@@ -9,6 +9,7 @@ , simplifyLambda , simplifyFun , simplifyStms+ , simplifyConsts , simpleSOACS , simplifySOAC@@ -62,7 +63,8 @@ tps2 = map (snd . patElemAttr) $ patternElements $ stmPattern bnd in namesFromList $ subExpVars $ concatMap arrayDims (tps1 ++ tps2) -simplifyFun :: MonadFreshNames m => FunDef SOACS -> m (FunDef SOACS)+simplifyFun :: MonadFreshNames m =>+ ST.SymbolTable (Wise SOACS) -> FunDef SOACS -> m (FunDef SOACS) simplifyFun = Simplify.simplifyFun simpleSOACS soacRules Engine.noExtraHoistBlockers @@ -72,9 +74,16 @@ Simplify.simplifyLambda simpleSOACS soacRules Engine.noExtraHoistBlockers simplifyStms :: (HasScope SOACS m, MonadFreshNames m) =>- Stms SOACS -> m (Stms SOACS)-simplifyStms =+ Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS)+simplifyStms stms = do+ scope <- askScope Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers+ scope stms++simplifyConsts :: MonadFreshNames m =>+ Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS)+simplifyConsts =+ Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers mempty simplifySOAC :: Simplify.SimplifiableLore lore => Simplify.SimplifyOp lore (SOAC lore)
src/Futhark/Transform/CopyPropagate.hs view
@@ -4,24 +4,38 @@ -- simplifier with no rules, so hoisting and dead-code elimination may -- also take place. module Futhark.Transform.CopyPropagate- ( copyPropagateInStms- , copyPropagateInFun)- where+ ( copyPropagateInProg+ , copyPropagateInStms+ , copyPropagateInFun+ )+where +import Futhark.Pass import Futhark.MonadFreshNames import Futhark.Representation.AST import Futhark.Optimise.Simplify+import qualified Futhark.Analysis.SymbolTable as ST+import Futhark.Optimise.Simplify.Lore (Wise) +-- | Run copy propagation on an entire program.+copyPropagateInProg :: SimplifiableLore lore =>+ SimpleOps lore+ -> Prog lore+ -> PassM (Prog lore)+copyPropagateInProg simpl = simplifyProg simpl mempty noExtraHoistBlockers+ -- | Run copy propagation on some statements.-copyPropagateInStms :: (MonadFreshNames m, SimplifiableLore lore, HasScope lore m) =>+copyPropagateInStms :: (MonadFreshNames m, SimplifiableLore lore) => SimpleOps lore+ -> Scope lore -> Stms lore- -> m (Stms lore)+ -> m (ST.SymbolTable (Wise lore), Stms lore) copyPropagateInStms simpl = simplifyStms simpl mempty noExtraHoistBlockers -- | Run copy propagation on a function. copyPropagateInFun :: (MonadFreshNames m, SimplifiableLore lore) => SimpleOps lore- -> FunDef lore- -> m (FunDef lore)+ -> ST.SymbolTable (Wise lore)+ -> FunDef lore+ -> m (FunDef lore) copyPropagateInFun simpl = simplifyFun simpl mempty noExtraHoistBlockers
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -8,6 +8,7 @@ -- transformations in-place. module Futhark.Transform.FirstOrderTransform ( transformFunDef+ , transformStms , Transformer , transformStmRecursively@@ -32,11 +33,19 @@ transformFunDef :: (MonadFreshNames m, Bindable tolore, BinderOps tolore, LetAttr SOACS ~ LetAttr tolore, CanBeAliased (Op tolore)) =>- FunDef SOACS -> m (AST.FunDef tolore)-transformFunDef (FunDef entry fname rettype params body) = do- (body',_) <- modifyNameSource $ runState $ runBinderT m mempty+ Scope tolore -> FunDef SOACS -> m (AST.FunDef tolore)+transformFunDef consts_scope (FunDef entry fname rettype params body) = do+ (body',_) <- modifyNameSource $ runState $ runBinderT m consts_scope return $ FunDef entry fname rettype params body' where m = localScope (scopeOfFParams params) $ insertStmsM $ transformBody body++transformStms :: (MonadFreshNames m, Bindable tolore, BinderOps tolore,+ LetAttr SOACS ~ LetAttr tolore,+ CanBeAliased (Op tolore)) =>+ Stms SOACS -> m (AST.Stms tolore)+transformStms stms =+ fmap snd $ modifyNameSource $ runState $ runBinderT m mempty+ where m = mapM_ transformStmRecursively stms -- | The constraints that a monad must uphold in order to be used for -- first-order transformation.
src/Futhark/Transform/Rename.hs view
@@ -22,7 +22,6 @@ , renameStm , renameBody , renameLambda- , renameFun , renamePattern -- * Renaming annotations , RenameM@@ -56,8 +55,10 @@ -- invalid program valid. renameProg :: (Renameable lore, MonadFreshNames m) => Prog lore -> m (Prog lore)-renameProg prog = modifyNameSource $- runRenamer $ Prog <$> mapM rename (progFuns prog)+renameProg prog = modifyNameSource $ runRenamer $+ renamingStms (progConsts prog) $ \consts -> do+ funs <- mapM rename (progFuns prog)+ return prog { progConsts = consts, progFuns = funs } -- | Rename bound variables such that each is unique. The semantics -- of the expression is unaffected, under the assumption that the@@ -91,14 +92,6 @@ renameLambda :: (Renameable lore, MonadFreshNames m) => Lambda lore -> m (Lambda lore) renameLambda = modifyNameSource . runRenamer . rename---- | Rename bound variables such that each is unique. The semantics--- of the function is unaffected, under the assumption that the body--- was correct to begin with. Any free variables are left untouched.--- Note in particular that the parameters of the lambda are renamed.-renameFun :: (Renameable lore, MonadFreshNames m) =>- FunDef lore -> m (FunDef lore)-renameFun = modifyNameSource . runRenamer . rename -- | Produce an equivalent pattern but with each pattern element given -- a new name.
src/Futhark/TypeCheck.hs view
@@ -118,11 +118,12 @@ "Call of unknown function " ++ nameToString fname ++ "." show (ParameterMismatch fname expected got) = "In call of " ++ fname' ++ ":\n" ++- "expecting " ++ show nexpected ++ " argument(s) of type(s) " ++- expected' ++ ", but got " ++ show ngot ++- " arguments of types " ++ intercalate ", " (map pretty got) ++ "."- where (nexpected, expected') =- (length expected, intercalate ", " $ map pretty expected)+ "expecting " ++ show nexpected ++ " arguments of type(s)\n" +++ intercalate ", " (map pretty expected) +++ "\nGot " ++ show ngot +++ " arguments of types\n" +++ intercalate ", " (map pretty got)+ where nexpected = length expected ngot = length got fname' = maybe "anonymous function" (("function "++) . nameToString) fname show (SlicingError dims got) =@@ -453,31 +454,32 @@ -- information. checkProg :: Checkable lore => Prog (Aliases lore) -> Either (TypeError lore) ()-checkProg prog = do+checkProg (Prog consts funs) = do let typeenv = Env { envVtable = M.empty , envFtable = mempty , envContext = [] , envCheckOp = checkOp }- let onFunction ftable fun =+ let onFunction ftable vtable fun = fmap fst $ runTypeM typeenv $- local (\env -> env { envFtable = ftable }) $+ local (\env -> env { envFtable = ftable, envVtable = vtable }) $ checkFun fun (ftable, _) <- runTypeM typeenv buildFtable- sequence_ $ parMap rpar (onFunction ftable) $ progFuns prog+ (vtable, _) <- runTypeM typeenv { envFtable = ftable } $+ checkStms consts $ asks envVtable+ sequence_ $ parMap rpar (onFunction ftable vtable) funs where- buildFtable = do table <- initialFtable prog- foldM expand table $ progFuns prog+ buildFtable = do table <- initialFtable+ foldM expand table funs expand ftable (FunDef _ name ret params _) | M.member name ftable = bad $ DupDefinitionError name | otherwise = return $ M.insert name (ret,params) ftable --- The prog argument is just to disambiguate the lore. initialFtable :: Checkable lore =>- Prog (Aliases lore) -> TypeM lore (M.Map Name (FunBinding lore))-initialFtable _ = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions+ TypeM lore (M.Map Name (FunBinding lore))+initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions where addBuiltin (fname, (t, ts)) = do ps <- mapM (primFParam name) ts return (fname, ([primRetType t], ps))
src/Futhark/Util/Pretty.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}--- | A re-export of the prettyprinting library, along with a convenience function.+-- | A re-export of the prettyprinting library, along with some convenience functions. module Futhark.Util.Pretty ( module Text.PrettyPrint.Mainland , module Text.PrettyPrint.Mainland.Class@@ -15,11 +15,16 @@ , nestedBlock , textwrap , shorten++ , color+ , inRed+ , inGreen ) where import Data.Text (Text) import qualified Data.Text.Lazy as LT+import System.Console.ANSI import Text.PrettyPrint.Mainland hiding (pretty) import Text.PrettyPrint.Mainland.Class@@ -82,3 +87,12 @@ shorten a | length s > 70 = text (take 70 s) <> text "..." | otherwise = text s where s = pretty a++color :: [SGR] -> String -> String+color sgr s = setSGRCode sgr ++ s ++ setSGRCode [Reset]++inRed :: String -> String+inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset]++inGreen :: String -> String+inGreen s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset]
src/Futhark/Util/Table.hs view
@@ -8,6 +8,8 @@ import Data.List (intercalate, transpose) import System.Console.ANSI +import Futhark.Util.Pretty (color)+ data RowTemplate = RowTemplate [Int] Int deriving (Show) -- | A table entry. Consists of the content as well a list of@@ -17,9 +19,6 @@ -- | Makes a table entry with the default SGR mode. mkEntry :: String -> (String, [SGR]) mkEntry s = (s, [])--color :: [SGR] -> String -> String-color sgr s = setSGRCode sgr ++ s ++ setSGRCode [Reset] buildRowTemplate :: [[Entry]] -> Int -> RowTemplate
src/Language/Futhark/TypeChecker.hs view
@@ -511,8 +511,8 @@ onRetType _ (Scalar (Arrow _ _ t1 t2)) = let (xs, y) = onRetType Nothing t2 in (EntryType t1 Nothing : xs, y)- onRetType _ t =- ([], EntryType t Nothing)+ onRetType te t =+ ([], EntryType t te) checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind) checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc loc) = do
src/Language/Futhark/TypeChecker/Monad.hs view
@@ -97,7 +97,7 @@ instance Pretty TypeError where ppr (TypeError loc notes msg) =- "Error at" <+> text (locStr loc) <+> ":" </>+ text (inRed $ "Error at " <> locStr loc <> ":") </> msg <> ppr notes unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a
src/futhark.hs view
@@ -15,6 +15,7 @@ import Prelude +import Futhark.Error import Futhark.Util.Options import qualified Futhark.CLI.Dev as Dev@@ -83,9 +84,20 @@ -- | Catch all IO exceptions and print a better error message if they -- happen. reportingIOErrors :: IO () -> IO ()-reportingIOErrors = flip catches [Handler onExit, Handler onError]+reportingIOErrors = flip catches [Handler onExit, Handler onICE, Handler onError] where onExit :: ExitCode -> IO () onExit = throwIO++ onICE :: InternalError -> IO ()+ onICE (Error CompilerLimitation s) = do+ T.hPutStrLn stderr "Known compiler limitation encountered. Sorry."+ T.hPutStrLn stderr "Revise your program or try a different Futhark compiler."+ T.hPutStrLn stderr s+ onICE (Error CompilerBug s) = do+ T.hPutStrLn stderr "Internal compiler error."+ T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues."+ T.hPutStrLn stderr s+ onError :: SomeException -> IO () onError e | Just UserInterrupt <- asyncExceptionFromException e =