futhark 0.19.5 → 0.19.6

raw patch · 68 files changed

+3410/−3044 lines, 68 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/man/futhark-autotune.rst +0/−2
• docs/man/futhark-c.rst +2/−2
• docs/man/futhark-cuda.rst +2/−2
• docs/man/futhark-literate.rst +2/−0
• docs/man/futhark-multicore.rst +2/−2
• docs/man/futhark-opencl.rst +2/−2
• docs/man/futhark-pyopencl.rst +2/−2
• docs/man/futhark-python.rst +2/−2
• docs/man/futhark-test.rst +14/−5
• docs/man/futhark.rst +1/−1
• docs/server-protocol.rst +14/−0
• futhark.cabal +4/−2
• rts/c/cuda.h +46/−14
• rts/c/server.h +24/−0
• rts/python/server.py +14/−2
• src/Futhark/Actions.hs +74/−14
• src/Futhark/Bench.hs +4/−14
• src/Futhark/CLI/Literate.hs +1/−1
• src/Futhark/CLI/PyOpenCL.hs +3/−18
• src/Futhark/CLI/Python.hs +3/−18
• src/Futhark/CLI/REPL.hs +27/−38
• src/Futhark/CLI/Test.hs +17/−26
• src/Futhark/CodeGen/Backends/CCUDA.hs +11/−11
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +18/−18
• src/Futhark/CodeGen/Backends/GenericC.hs +49/−66
• src/Futhark/CodeGen/Backends/GenericC/CLI.hs +77/−75
• src/Futhark/CodeGen/Backends/GenericC/Server.hs +15/−15
• src/Futhark/CodeGen/Backends/GenericPython.hs +73/−82
• src/Futhark/CodeGen/Backends/MulticoreC.hs +3/−3
• src/Futhark/CodeGen/ImpCode.hs +4/−1
• src/Futhark/CodeGen/ImpGen.hs +40/−5
• src/Futhark/CodeGen/ImpGen/Kernels.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +2/−0
• src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +9/−7
• src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +55/−87
• src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Transpose.hs +1/−1
• src/Futhark/Compiler.hs +3/−35
• src/Futhark/Compiler/CLI.hs +2/−7
• src/Futhark/Compiler/Config.hs +39/−0
• src/Futhark/Compiler/Program.hs +3/−1
• src/Futhark/IR/Parse.hs +5/−1
• src/Futhark/IR/Pretty.hs +7/−3
• src/Futhark/IR/Primitive.hs +6/−3
• src/Futhark/IR/Syntax.hs +1/−1
• src/Futhark/Internalise.hs +44/−2133
• src/Futhark/Internalise/Bindings.hs +13/−22
• src/Futhark/Internalise/Defunctionalise.hs +27/−25
• src/Futhark/Internalise/Exps.hs +2126/−0
• src/Futhark/Internalise/Monad.hs +12/−27
• src/Futhark/Internalise/TypesValues.hs +5/−2
• src/Futhark/Optimise/Fusion.hs +4/−2
• src/Futhark/Optimise/TileLoops.hs +20/−6
• src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +3/−4
• src/Futhark/Script.hs +92/−37
• src/Futhark/Server.hs +16/−0
• src/Futhark/Test.hs +148/−47
• src/Futhark/Test/Values.hs +24/−9
• src/Futhark/Transform/FirstOrderTransform.hs +32/−39
• src/Futhark/TypeCheck.hs +33/−23
• src/Futhark/Util.hs +14/−0
• src/Language/Futhark.hs +4/−0
• src/Language/Futhark/Interpreter.hs +7/−1
• src/Language/Futhark/Parser/Parser.y +2/−2
• src/Language/Futhark/Prop.hs +4/−0
• src/Language/Futhark/Syntax.hs +8/−4
• src/Language/Futhark/TypeChecker/Terms.hs +85/−66
• src/Language/Futhark/TypeChecker/Unify.hs +2/−4

@@ -23,8 +23,6 @@ automatically be picked up by subsequent uses of :ref:`futhark-bench(1)` and :ref:`futhark-test(1)`. -Currently, only the entry point named ``main`` is tuned.-  OPTIONS =======

@@ -31,8 +31,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Generate a library instead of an executable.  Appends ``.c``/``.h``

@@ -35,8 +35,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Generate a library instead of an executable.  Appends ``.c``/``.h``

@@ -196,7 +196,9 @@             : | "empty" "(" ("[" `decimal` "]" )+ `script_type` ")"             : | "{" "}"             : | "{" (`id` = `script_exp`) ("," `id` = `script_exp`)* "}"+            : | "let" `script_pat` "=" `script_exp` "in" `script_exp`             : | `literal`+   script_pat:  `id` | "(" `id` ("," `id`) ")"    script_fun:  `id` | "$" `id`    script_type: `int_type` | `float_type` | "bool" 

@@ -31,8 +31,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Generate a library instead of an executable.  Appends ``.c``/``.h``

@@ -31,8 +31,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Generate a library instead of an executable.  Appends ``.c``/``.h``

@@ -37,8 +37,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Instead of compiling to an executable program, generate a Python

@@ -31,8 +31,8 @@ -h   Print help text to standard output and exit. ---entry NAME-  Treat the specified top-level function as an entry point.+--entry-point NAME+  Treat this top-level function as an entry point.  --library   Instead of compiling to an executable program, generate a Python

@@ -36,7 +36,7 @@    [tags { tags... }]   [entry: names...]-  [compiled|nobench|random] input ({ values... } | @ filename)+  [compiled|nobench|random|script] input ({ values... } | @ filename)   output { values... } | auto output | error: regex  If ``compiled`` is present before the ``input`` keyword, this test@@ -53,10 +53,18 @@ from sizes, integer constants (with or without type suffix), and floating-point constants (always with type suffix) are also permitted. +If ``input`` is preceded by ``script``, the text between the curly+braces is interpreted as a FutharkScript expression (see+:ref:`futhark-literate(1)`), which is executed to generate the input.+It must use only functions explicitly declared as entry points.  If+the expression produces an *n*-element tuple, it will be unpacked and+its components passed as *n* distinct arguments to the test function.+ If ``input`` is followed by an ``@`` and a file name (which must not-contain any whitespace) instead of curly braces, values will be read-from the indicated file.  This is recommended for large data sets.-This notation cannot be used with ``random`` input.+contain any whitespace) instead of curly braces, values or+FutharkScript expression will be read from the indicated file.  This+is recommended for large data sets.  This notation cannot be used with+``random`` input.  After the ``input`` block, the expected result of the test case is written as either ``output`` followed by another block of values, or@@ -71,7 +79,8 @@ with ``futhark-c`` and recording its result for the given input (which must not fail).  This is usually only useful for testing or benchmarking alternative compilers, and not for testing the-correctness of Futhark programs.+correctness of Futhark programs.  This currently does not work for+``script`` inputs.  Alternatively, instead of input-output pairs, the test cases can simply be a description of an expected compile time type error::

@@ -45,7 +45,7 @@  Find the test dataset whose description contains ``DATASET`` (e.g. ``#1``) and print it in binary representation to standard-output.+output.  This does not work for ``script`` datasets.  futhark dev options... PROGRAM ------------------------------

@@ -82,6 +82,12 @@  Delete the given variables. +``rename`` *oldname* *newname*+..............................++Rename the variable *oldname* to *newname*, which must not already+exist.+ ``inputs`` *entry* .................. @@ -114,3 +120,11 @@ ..........  Corresponds to :c:func:`futhark_context_report`.++Environment Variables+---------------------++``FUTHARK_COMPILER_DEBUGGING``+..............................++Turns on debugging output for the server when set to 1.

@@ -1,7 +1,7 @@ cabal-version: 2.4 -- Run 'cabal2nix . >futhark.nix' after adding deps. name:           futhark-version:        0.19.5+version:        0.19.6 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -140,6 +140,7 @@       Futhark.CodeGen.SetDefaultSpace       Futhark.Compiler       Futhark.Compiler.CLI+      Futhark.Compiler.Config       Futhark.Compiler.Program       Futhark.Construct       Futhark.Doc.Generator@@ -188,6 +189,7 @@       Futhark.Internalise.Bindings       Futhark.Internalise.Defunctionalise       Futhark.Internalise.Defunctorise+      Futhark.Internalise.Exps       Futhark.Internalise.FreeVars       Futhark.Internalise.Lambdas       Futhark.Internalise.LiftLambdas@@ -346,7 +348,7 @@   main-is: src/futhark.hs   other-modules:       Paths_futhark-  ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg -H1G -A4M"+  ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M"   build-depends:       base     , futhark

@@ -1,9 +1,28 @@ // Start of cuda.h. -#define CUDA_SUCCEED(x) cuda_api_succeed(x, #x, __FILE__, __LINE__)+#define CUDA_SUCCEED_FATAL(x) cuda_api_succeed_fatal(x, #x, __FILE__, __LINE__)+#define CUDA_SUCCEED_NONFATAL(x) cuda_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) #define NVRTC_SUCCEED(x) nvrtc_api_succeed(x, #x, __FILE__, __LINE__) -static inline void cuda_api_succeed(CUresult res, const char *call,+#define CUDA_SUCCEED_OR_RETURN(e) {             \+    char *serror = CUDA_SUCCEED_NONFATAL(e);    \+    if (serror) {                                 \+      if (!ctx->error) {                          \+        ctx->error = serror;                      \+        return bad;                               \+      } else {                                    \+        free(serror);                             \+      }                                           \+    }                                             \+  }++// CUDA_SUCCEED_OR_RETURN returns the value of the variable 'bad' in+// scope.  By default, it will be this one.  Create a local variable+// of some other type if needed.  This is a bit of a hack, but it+// saves effort in the code generator.+static const int bad = 1;++static inline void cuda_api_succeed_fatal(CUresult res, const char *call,     const char *file, int line) {   if (res != CUDA_SUCCESS) {     const char *err_str;@@ -14,6 +33,19 @@   } } +static char* cuda_api_succeed_nonfatal(CUresult res, const char *call,+    const char *file, int line) {+  if (res != CUDA_SUCCESS) {+    const char *err_str;+    cuGetErrorString(res, &err_str);+    if (err_str == NULL) { err_str = "Unknown"; }+    return msgprintf("%s:%d: CUDA call\n  %s\nfailed with error code %d (%s)\n",+        file, line, call, res, err_str);+  } else {+    return NULL;+  }+}+ static inline void nvrtc_api_succeed(nvrtcResult res, const char *call,                                      const char *file, int line) {   if (res != NVRTC_SUCCESS) {@@ -119,7 +151,7 @@ #define device_query(dev,attrib) _device_query(dev, CU_DEV_ATTR(attrib)) static int _device_query(CUdevice dev, CUdevice_attribute attrib) {   int val;-  CUDA_SUCCEED(cuDeviceGetAttribute(&val, attrib, dev));+  CUDA_SUCCEED_FATAL(cuDeviceGetAttribute(&val, attrib, dev));   return val; } @@ -127,7 +159,7 @@ #define function_query(fn,attrib) _function_query(dev, CU_FUN_ATTR(attrib)) static int _function_query(CUfunction dev, CUfunction_attribute attrib) {   int val;-  CUDA_SUCCEED(cuFuncGetAttribute(&val, attrib, dev));+  CUDA_SUCCEED_FATAL(cuFuncGetAttribute(&val, attrib, dev));   return val; } @@ -154,7 +186,7 @@   int cc_major, cc_minor;   CUdevice dev; -  CUDA_SUCCEED(cuDeviceGetCount(&count));+  CUDA_SUCCEED_FATAL(cuDeviceGetCount(&count));   if (count == 0) { return 1; }    int num_device_matches = 0;@@ -164,12 +196,12 @@   // This should maybe be changed, since greater compute capability is not   // necessarily an indicator of better performance.   for (int i = 0; i < count; i++) {-    CUDA_SUCCEED(cuDeviceGet(&dev, i));+    CUDA_SUCCEED_FATAL(cuDeviceGet(&dev, i));      cc_major = device_query(dev, COMPUTE_CAPABILITY_MAJOR);     cc_minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); -    CUDA_SUCCEED(cuDeviceGetName(name, sizeof(name) - 1, dev));+    CUDA_SUCCEED_FATAL(cuDeviceGetName(name, sizeof(name) - 1, dev));     name[sizeof(name) - 1] = 0;      if (ctx->cfg.debugging) {@@ -205,7 +237,7 @@     fprintf(stderr, "Using device #%d\n", chosen);   } -  CUDA_SUCCEED(cuDeviceGet(&ctx->dev, chosen));+  CUDA_SUCCEED_FATAL(cuDeviceGet(&ctx->dev, chosen));   return 0; } @@ -463,7 +495,7 @@     dump_file(ctx->cfg.dump_ptx_to, ptx, strlen(ptx));   } -  CUDA_SUCCEED(cuModuleLoadData(&ctx->module, ptx));+  CUDA_SUCCEED_FATAL(cuModuleLoadData(&ctx->module, ptx));    free(ptx);   if (src != NULL) {@@ -472,12 +504,12 @@ }  static void cuda_setup(struct cuda_context *ctx, const char *src_fragments[], const char *extra_opts[]) {-  CUDA_SUCCEED(cuInit(0));+  CUDA_SUCCEED_FATAL(cuInit(0));    if (cuda_device_setup(ctx) != 0) {     futhark_panic(-1, "No suitable CUDA device found.\n");   }-  CUDA_SUCCEED(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev));+  CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev));    free_list_init(&ctx->free_list); @@ -546,11 +578,11 @@ static CUresult cuda_free_all(struct cuda_context *ctx);  static void cuda_cleanup(struct cuda_context *ctx) {-  CUDA_SUCCEED(cuda_free_all(ctx));+  CUDA_SUCCEED_FATAL(cuda_free_all(ctx));   (void)cuda_tally_profiling_records(ctx);   free(ctx->profiling_records);-  CUDA_SUCCEED(cuModuleUnload(ctx->module));-  CUDA_SUCCEED(cuCtxDestroy(ctx->cu_ctx));+  CUDA_SUCCEED_FATAL(cuModuleUnload(ctx->module));+  CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx)); }  static CUresult cuda_alloc(struct cuda_context *ctx, size_t min_size,

@@ -425,6 +425,28 @@   } } +void cmd_rename(struct server_state *s, const char *args[]) {+  const char *oldname = get_arg(args, 0);+  const char *newname = get_arg(args, 1);+  struct variable *old = get_variable(s, oldname);+  struct variable *new = get_variable(s, newname);++  if (old == NULL) {+    failure();+    printf("Unknown variable: %s\n", oldname);+    return;+  }++  if (new != NULL) {+    failure();+    printf("Variable already exists: %s\n", newname);+    return;+  }++  free(old->name);+  old->name = strdup(newname);+}+ void cmd_inputs(struct server_state *s, const char *args[]) {   const char *name = get_arg(args, 0);   struct entry_point *e = get_entry_point(s, name);@@ -558,6 +580,8 @@     cmd_store(s, tokens+1);   } else if (strcmp(command, "free") == 0) {     cmd_free(s, tokens+1);+  } else if (strcmp(command, "rename") == 0) {+    cmd_rename(s, tokens+1);   } else if (strcmp(command, "inputs") == 0) {     cmd_inputs(s, tokens+1);   } else if (strcmp(command, "outputs") == 0) {

@@ -29,6 +29,10 @@         if not vname in self._vars:             raise self.Failure('Unknown variable: %s' % vname) +    def _check_new_var(self, vname):+        if vname in self._vars:+            raise self.Failure('Variable already exists: %s' % vname)+     def _get_var(self, vname):         self._check_var(vname)         return self._vars[vname]@@ -51,6 +55,14 @@             self._check_var(vname)             del self._vars[vname] +    def _cmd_rename(self, args):+        oldname = self._get_arg(args, 0)+        newname = self._get_arg(args, 1)+        self._check_var(oldname)+        self._check_new_var(newname)+        self._vars[newname] = self._vars[oldname]+        del self._vars[oldname]+     def _cmd_call(self, args):         entry = self._get_entry_point(self._get_arg(args, 0))         num_ins = len(entry[0])@@ -63,8 +75,7 @@         out_vnames = args[1:num_outs+1]          for out_vname in out_vnames:-            if out_vname in self._vars:-                raise self.Failure('Variable already exists: %s' % out_vname)+            self._check_new_var(out_vname)          in_vnames = args[1+num_outs:]         ins = [ self._get_var(in_vname) for in_vname in in_vnames ]@@ -146,6 +157,7 @@                   'restore': _cmd_restore,                   'store': _cmd_store,                   'free': _cmd_free,+                  'rename': _cmd_rename,                   'clear': _cmd_dummy,                   'pause_profiling': _cmd_dummy,                   'unpause_profiling': _cmd_dummy,

@@ -13,6 +13,8 @@     compileOpenCLAction,     compileCUDAAction,     compileMulticoreAction,+    compilePythonAction,+    compilePyOpenCLAction,   ) where @@ -24,7 +26,9 @@ import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL import qualified Futhark.CodeGen.Backends.MulticoreC as MulticoreC+import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC+import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGenMulticore import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential@@ -35,6 +39,8 @@ import Futhark.IR.Prop.Aliases import Futhark.IR.SeqMem (SeqMem) import Futhark.Util (runProgramWithExitCode, unixEnvironment)+import Futhark.Version (versionString)+import System.Directory import System.Exit import System.FilePath import qualified System.Info@@ -93,6 +99,22 @@       actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenMulticore.compileProg     } +-- Lines that we prepend (in comments) to generated code.+headerLines :: [String]+headerLines = lines $ "Generated by Futhark " ++ versionString++cHeaderLines :: [String]+cHeaderLines = map ("// " <>) headerLines++pyHeaderLines :: [String]+pyHeaderLines = map ("# " <>) headerLines++cPrependHeader :: String -> String+cPrependHeader = (unlines cHeaderLines ++)++pyPrependHeader :: String -> String+pyPrependHeader = (unlines pyHeaderLines ++)+ cmdCC :: String cmdCC = fromMaybe "cc" $ lookup "CC" unixEnvironment @@ -141,8 +163,8 @@       case mode of         ToLibrary -> do           let (header, impl) = SequentialC.asLibrary cprog-          liftIO $ writeFile hpath header-          liftIO $ writeFile cpath impl+          liftIO $ writeFile hpath $ cPrependHeader header+          liftIO $ writeFile cpath $ cPrependHeader impl         ToExecutable -> do           liftIO $ writeFile cpath $ SequentialC.asExecutable cprog           runCC cpath outpath ["-O3", "-std=c99"] ["-lm"]@@ -174,13 +196,13 @@       case mode of         ToLibrary -> do           let (header, impl) = COpenCL.asLibrary cprog-          liftIO $ writeFile hpath header-          liftIO $ writeFile cpath impl+          liftIO $ writeFile hpath $ cPrependHeader header+          liftIO $ writeFile cpath $ cPrependHeader impl         ToExecutable -> do-          liftIO $ writeFile cpath $ COpenCL.asExecutable cprog+          liftIO $ writeFile cpath $ cPrependHeader $ COpenCL.asExecutable cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)         ToServer -> do-          liftIO $ writeFile cpath $ COpenCL.asServer cprog+          liftIO $ writeFile cpath $ cPrependHeader $ COpenCL.asServer cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)  -- | The @futhark cuda@ action.@@ -204,13 +226,13 @@       case mode of         ToLibrary -> do           let (header, impl) = CCUDA.asLibrary cprog-          liftIO $ writeFile hpath header-          liftIO $ writeFile cpath impl+          liftIO $ writeFile hpath $ cPrependHeader header+          liftIO $ writeFile cpath $ cPrependHeader impl         ToExecutable -> do-          liftIO $ writeFile cpath $ CCUDA.asExecutable cprog+          liftIO $ writeFile cpath $ cPrependHeader $ CCUDA.asExecutable cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)         ToServer -> do-          liftIO $ writeFile cpath $ CCUDA.asServer cprog+          liftIO $ writeFile cpath $ cPrependHeader $ CCUDA.asServer cprog           runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options)  -- | The @futhark multicore@ action.@@ -230,11 +252,49 @@       case mode of         ToLibrary -> do           let (header, impl) = MulticoreC.asLibrary cprog-          liftIO $ writeFile hpath header-          liftIO $ writeFile cpath impl+          liftIO $ writeFile hpath $ cPrependHeader header+          liftIO $ writeFile cpath $ cPrependHeader impl         ToExecutable -> do-          liftIO $ writeFile cpath $ MulticoreC.asExecutable cprog+          liftIO $ writeFile cpath $ cPrependHeader $ MulticoreC.asExecutable cprog           runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"]         ToServer -> do-          liftIO $ writeFile cpath $ MulticoreC.asServer cprog+          liftIO $ writeFile cpath $ cPrependHeader $ MulticoreC.asServer cprog           runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"]++pythonCommon ::+  (CompilerMode -> String -> prog -> FutharkM (Warnings, String)) ->+  FutharkConfig ->+  CompilerMode ->+  FilePath ->+  prog ->+  FutharkM ()+pythonCommon codegen fcfg mode outpath prog = do+  let class_name =+        case mode of+          ToLibrary -> takeBaseName outpath+          _ -> "internal"+  pyprog <- handleWarnings fcfg $ codegen mode class_name prog++  case mode of+    ToLibrary ->+      liftIO $ writeFile (outpath `addExtension` "py") $ pyPrependHeader pyprog+    _ -> liftIO $ do+      writeFile outpath $ "#!/usr/bin/env python3\n" ++ pyPrependHeader pyprog+      perms <- liftIO $ getPermissions outpath+      setPermissions outpath $ setOwnerExecutable True perms++compilePythonAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem+compilePythonAction fcfg mode outpath =+  Action+    { actionName = "Compile to PyOpenCL",+      actionDescription = "Compile to Python with OpenCL",+      actionProcedure = pythonCommon SequentialPy.compileProg fcfg mode outpath+    }++compilePyOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem+compilePyOpenCLAction fcfg mode outpath =+  Action+    { actionName = "Compile to PyOpenCL",+      actionDescription = "Compile to Python with OpenCL",+      actionProcedure = pythonCommon PyOpenCL.compileProg fcfg mode outpath+    }

@@ -139,12 +139,6 @@     runResultAction :: Maybe (Int -> IO ())   } -cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()-cmdMaybe = maybe (pure ()) (throwError . T.unlines . failureMsg) <=< liftIO--cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a-cmdEither = either (throwError . T.unlines . failureMsg) pure <=< liftIO- -- | Run the benchmark program on the indicated dataset. benchmarkDataset ::   Server ->@@ -161,17 +155,13 @@   input_types <- cmdEither $ cmdInputs server entry   let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types -1]]       ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types -1]]-      freeOuts = cmdMaybe (cmdFree server outs)-      freeIns = cmdMaybe (cmdFree server ins)    cmdMaybe . liftIO $ cmdClear server -  either throwError pure-    <=< withValuesFile futhark dir input_spec-    $ \values_f ->-      runExceptT $ do-        checkValueTypes values_f input_types-        cmdMaybe $ cmdRestore server values_f (zip ins input_types)+  valuesAsVars server (zip ins input_types) futhark dir input_spec++  let freeOuts = cmdMaybe (cmdFree server outs)+      freeIns = cmdMaybe (cmdFree server ins)    let runtime l         | Just l' <- T.stripPrefix "runtime: " l,

@@ -851,7 +851,7 @@       script <- parseProgFile prog        unless (scriptSkipCompilation opts) $ do-        let entryOpt v = "--entry=" ++ T.unpack v+        let entryOpt v = "--entry-point=" ++ T.unpack v             compile_options =               "--server" :               map entryOpt (S.toList (varsInScripts script))

@@ -3,12 +3,9 @@ -- | @futhark pyopencl@ module Futhark.CLI.PyOpenCL (main) where -import Control.Monad.IO.Class-import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL+import Futhark.Actions (compilePyOpenCLAction) import Futhark.Compiler.CLI import Futhark.Passes-import System.Directory-import System.FilePath  -- | Run @futhark pyopencl@. main :: String -> [String] -> IO ()@@ -18,17 +15,5 @@   "Compile PyOpenCL"   "Generate Python + OpenCL code from optimised Futhark program."   gpuPipeline-  $ \fcfg () mode outpath prog -> do-    let class_name =-          case mode of-            ToLibrary -> takeBaseName outpath-            _ -> "internal"-    pyprog <- handleWarnings fcfg $ PyOpenCL.compileProg mode class_name prog--    case mode of-      ToLibrary ->-        liftIO $ writeFile (outpath `addExtension` "py") pyprog-      _ -> liftIO $ do-        writeFile outpath pyprog-        perms <- liftIO $ getPermissions outpath-        setPermissions outpath $ setOwnerExecutable True perms+  $ \fcfg () mode outpath prog ->+    actionProcedure (compilePyOpenCLAction fcfg mode outpath) prog

@@ -3,12 +3,9 @@ -- | @futhark py@ module Futhark.CLI.Python (main) where -import Control.Monad.IO.Class-import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy+import Futhark.Actions (compilePythonAction) import Futhark.Compiler.CLI import Futhark.Passes-import System.Directory-import System.FilePath  -- | Run @futhark py@ main :: String -> [String] -> IO ()@@ -18,17 +15,5 @@   "Compile sequential Python"   "Generate sequential Python code from optimised Futhark program."   sequentialCpuPipeline-  $ \fcfg () mode outpath prog -> do-    let class_name =-          case mode of-            ToLibrary -> takeBaseName outpath-            _ -> "internal"-    pyprog <- handleWarnings fcfg $ SequentialPy.compileProg mode class_name prog--    case mode of-      ToLibrary ->-        liftIO $ writeFile (outpath `addExtension` "py") pyprog-      _ -> liftIO $ do-        writeFile outpath pyprog-        perms <- liftIO $ getPermissions outpath-        setPermissions outpath $ setOwnerExecutable True perms+  $ \fcfg () mode outpath prog ->+    actionProcedure (compilePythonAction fcfg mode outpath) prog

@@ -22,7 +22,7 @@ import Futhark.Compiler import Futhark.MonadFreshNames import Futhark.Pipeline-import Futhark.Util (toPOSIX)+import Futhark.Util (fancyTerminal, toPOSIX) import Futhark.Util.Options import Futhark.Version import Language.Futhark@@ -57,12 +57,13 @@  repl :: Maybe FilePath -> IO () repl maybe_prog = do-  putStr banner-  putStrLn $ "Version " ++ showVersion version ++ "."-  putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."-  putStrLn ""-  putStrLn "Run :help for a list of commands."-  putStrLn ""+  when fancyTerminal $ do+    putStr banner+    putStrLn $ "Version " ++ showVersion version ++ "."+    putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."+    putStrLn ""+    putStrLn "Run :help for a list of commands."+    putStrLn ""    let toploop s = do         (stop, s') <- runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) s@@ -82,7 +83,7 @@           Right _ -> return ()        finish s = do-        quit <- confirmQuit+        quit <- if fancyTerminal then confirmQuit else pure True         if quit then return () else toploop s    maybe_init_state <- liftIO $ newFutharkiState 0 maybe_prog@@ -167,14 +168,9 @@        -- Then make the prelude available in the type checker.       (tenv, d, src') <--        badOnLeft pretty $-          snd $-            T.checkDec-              imports-              src-              T.initialEnv-              (T.mkInitialImport ".")-              $ mkOpen "/prelude/prelude"+        badOnLeft pretty . snd $+          T.checkDec imports src T.initialEnv (T.mkInitialImport ".") $+            mkOpen "/prelude/prelude"       -- Then in the interpreter.       ienv' <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv d)       return (imports, src', tenv, ienv')@@ -193,15 +189,11 @@         foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $           map (fmap fileProg) imports       (tenv1, d1, src') <--        badOnLeft pretty $-          snd $-            T.checkDec imports src T.initialEnv imp $-              mkOpen "/prelude/prelude"+        badOnLeft pretty . snd . T.checkDec imports src T.initialEnv imp $+          mkOpen "/prelude/prelude"       (tenv2, d2, src'') <--        badOnLeft pretty $-          snd $-            T.checkDec imports src' tenv1 imp $-              mkOpen $ toPOSIX $ dropExtension file+        badOnLeft pretty . snd . T.checkDec imports src' tenv1 imp $+          mkOpen $ toPOSIX $ dropExtension file       ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)       ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)       return (imports, src'', tenv2, ienv3)@@ -257,10 +249,9 @@         [] -> liftIO $ T.putStrLn $ "Unknown command '" <> cmdname <> "'"         [(_, (cmdf, _))] -> cmdf arg         matches ->-          liftIO $-            T.putStrLn $-              "Ambiguous command; could be one of "-                <> mconcat (intersperse ", " (map fst matches))+          liftIO . T.putStrLn $+            "Ambiguous command; could be one of "+              <> mconcat (intersperse ", " (map fst matches))     _ -> do       -- Read a declaration or expression.       maybe_dec_or_e <- parseDecOrExpIncrM (inputLine "  ") prompt line@@ -377,16 +368,14 @@         -- Note the cleverness to preserve the Haskeline session (for         -- line history and such).         (stop, s') <--          FutharkiM $-            lift $-              lift $-                runStateT-                  (runExceptT $ runFutharkiM $ forever readEvalPrint)-                  s-                    { futharkiEnv = (tenv, ctx),-                      futharkiCount = futharkiCount s + 1,-                      futharkiBreaking = Just breaking-                    }+          FutharkiM . lift . lift $+            runStateT+              (runExceptT $ runFutharkiM $ forever readEvalPrint)+              s+                { futharkiEnv = (tenv, ctx),+                  futharkiCount = futharkiCount s + 1,+                  futharkiBreaking = Just breaking+                }          case stop of           Left (Load file) -> throwError $ Load file

@@ -183,26 +183,21 @@ runInterpretedEntry (FutharkExe futhark) program (InputOutputs entry run_cases) =   let dir = takeDirectory program       runInterpretedCase run@(TestRun _ inputValues _ index _) =-        unless ("compiled" `elem` runTags run) $-          context-            ( "Entry point: " <> entry-                <> "; dataset: "-                <> T.pack (runDescription run)-            )-            $ do-              input <- T.unlines . map prettyText <$> getValues (FutharkExe futhark) dir inputValues-              expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run-              (code, output, err) <--                liftIO $-                  readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $-                    T.encodeUtf8 input-              case code of-                ExitFailure 127 ->-                  throwError $ progNotFound $ T.pack futhark-                _ ->-                  liftExcept $-                    compareResult entry index program expectedResult'-                      =<< runResult program code output err+        unless (any (`elem` runTags run) ["compiled", "script"]) $+          context ("Entry point: " <> entry <> "; dataset: " <> T.pack (runDescription run)) $ do+            input <- T.unlines . map prettyText <$> getValues (FutharkExe futhark) dir inputValues+            expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run+            (code, output, err) <-+              liftIO $+                readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $+                  T.encodeUtf8 input+            case code of+              ExitFailure 127 ->+                throwError $ progNotFound $ T.pack futhark+              _ ->+                liftExcept $+                  compareResult entry index program expectedResult'+                    =<< runResult program code output err    in accErrors_ $ map runInterpretedCase run_cases  runTestCase :: TestCase -> TestM ()@@ -286,7 +281,7 @@     dir = takeDirectory program      runCompiledCase input_types outs ins run = runExceptT $ do-      let TestRun _ inputValues _ index _ = run+      let TestRun _ input_spec _ index _ = run           case_ctx =             "Entry point: " <> entry <> "; dataset: "               <> T.pack (runDescription run)@@ -294,11 +289,7 @@       context1 case_ctx $ do         expected <- getExpectedResult futhark program entry run -        either E.throwError pure-          <=< withValuesFile futhark dir inputValues-          $ \values_f -> runExceptT $ do-            checkValueTypes values_f input_types-            liftCommand $ cmdRestore server values_f (zip ins input_types)+        valuesAsVars server (zip ins input_types) futhark dir input_spec          call_r <- liftIO $ cmdCall server entry outs ins         liftCommand $ cmdFree server ins

@@ -71,8 +71,8 @@           GC.opsCompiler = callKernel,           GC.opsFatMemory = True,           GC.opsCritical =-            ( [C.citems|CUDA_SUCCEED(cuCtxPushCurrent(ctx->cuda.cu_ctx));|],-              [C.citems|CUDA_SUCCEED(cuCtxPopCurrent(&ctx->cuda.cu_ctx));|]+            ( [C.citems|CUDA_SUCCEED_FATAL(cuCtxPushCurrent(ctx->cuda.cu_ctx));|],+              [C.citems|CUDA_SUCCEED_FATAL(cuCtxPopCurrent(&ctx->cuda.cu_ctx));|]             )         }     cuda_includes =@@ -140,7 +140,7 @@   GC.item     [C.citem|{$ty:t $id:val' = $exp:val;                   $items:bef-                  CUDA_SUCCEED(+                  CUDA_SUCCEED_OR_RETURN(                     cuMemcpyHtoD($exp:mem + $exp:idx * sizeof($ty:t),                                  &$id:val',                                  sizeof($ty:t)));@@ -159,7 +159,7 @@        $ty:t $id:val;        {        $items:bef-       CUDA_SUCCEED(+       CUDA_SUCCEED_OR_RETURN(           cuMemcpyDtoH(&$id:val,                        $exp:mem + $exp:idx * sizeof($ty:t),                        sizeof($ty:t)));@@ -173,13 +173,13 @@  allocateCUDABuffer :: GC.Allocate OpenCL () allocateCUDABuffer mem size tag "device" =-  GC.stm [C.cstm|CUDA_SUCCEED(cuda_alloc(&ctx->cuda, $exp:size, $exp:tag, &$exp:mem));|]+  GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_alloc(&ctx->cuda, $exp:size, $exp:tag, &$exp:mem));|] allocateCUDABuffer _ _ _ space =   error $ "Cannot allocate in '" ++ space ++ "' memory space."  deallocateCUDABuffer :: GC.Deallocate OpenCL () deallocateCUDABuffer mem tag "device" =-  GC.stm [C.cstm|CUDA_SUCCEED(cuda_free(&ctx->cuda, $exp:mem, $exp:tag));|]+  GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(&ctx->cuda, $exp:mem, $exp:tag));|] deallocateCUDABuffer _ _ space =   error $ "Cannot deallocate in '" ++ space ++ "' memory space." @@ -190,7 +190,7 @@   GC.item     [C.citem|{                 $items:bef-                CUDA_SUCCEED(+                CUDA_SUCCEED_OR_RETURN(                   $id:fn($exp:dstmem + $exp:dstidx,                          $exp:srcmem + $exp:srcidx,                          $exp:nbytes));@@ -227,10 +227,10 @@     [C.cstm|{     ctx->$id:name.references = NULL;     ctx->$id:name.size = 0;-    CUDA_SUCCEED(cuMemAlloc(&ctx->$id:name.mem,+    CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->$id:name.mem,                             ($int:num_elems > 0 ? $int:num_elems : 1)*sizeof($ty:ct)));     if ($int:num_elems > 0) {-      CUDA_SUCCEED(cuMemcpyHtoD(ctx->$id:name.mem, $id:name_realtype,+      CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->$id:name.mem, $id:name_realtype,                                 $int:num_elems*sizeof($ty:ct)));     }   }|]@@ -330,7 +330,7 @@         $id:time_start = get_wall_time();       }       $items:bef-      CUDA_SUCCEED(+      CUDA_SUCCEED_OR_RETURN(         cuLaunchKernel(ctx->$id:kernel_name,                        grid[0], grid[1], grid[2],                        $exp:block_x, $exp:block_y, $exp:block_z,@@ -338,7 +338,7 @@                        $id:args_arr, NULL));       $items:aft       if (ctx->debugging) {-        CUDA_SUCCEED(cuCtxSynchronize());+        CUDA_SUCCEED_FATAL(cuCtxSynchronize());         $id:time_end = get_wall_time();         fprintf(ctx->log, "Kernel %s runtime: %ldus\n",                 $string:(pretty kernel_name), $id:time_end - $id:time_start);

@@ -41,12 +41,12 @@         pevents = cuda_get_events(&ctx->cuda,                                   &ctx->$id:(kernelRuns name),                                   &ctx->$id:(kernelRuntime name));-        CUDA_SUCCEED(cudaEventRecord(pevents[0], 0));+        CUDA_SUCCEED_FATAL(cudaEventRecord(pevents[0], 0));       }       |],     [C.citems|       if (pevents != NULL) {-        CUDA_SUCCEED(cudaEventRecord(pevents[1], 0));+        CUDA_SUCCEED_FATAL(cudaEventRecord(pevents[1], 0));       }       |]   )@@ -77,7 +77,7 @@   cfg <- generateConfigFuns sizes   generateContextFuns cfg cost_centres kernels sizes failures -  GC.profileReport [C.citem|CUDA_SUCCEED(cuda_tally_profiling_records(&ctx->cuda));|]+  GC.profileReport [C.citem|CUDA_SUCCEED_FATAL(cuda_tally_profiling_records(&ctx->cuda));|]   mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels   where     cuda_h = $(embedStringFile "rts/c/cuda.h")@@ -309,10 +309,10 @@        forKernel name =         ( [C.csdecl|typename CUfunction $id:name;|],-          [C.cstm|CUDA_SUCCEED(cuModuleGetFunction(-                                &ctx->$id:name,-                                ctx->cuda.module,-                                $string:(pretty (C.toIdent name mempty))));|]+          [C.cstm|CUDA_SUCCEED_FATAL(cuModuleGetFunction(+                                     &ctx->$id:name,+                                     ctx->cuda.module,+                                     $string:(pretty (C.toIdent name mempty))));|]         ) :         forCostCentre name @@ -384,10 +384,10 @@                  cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts);                   typename int32_t no_error = -1;-                 CUDA_SUCCEED(cuMemAlloc(&ctx->global_failure, sizeof(no_error)));-                 CUDA_SUCCEED(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error)));+                 CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure, sizeof(no_error)));+                 CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error)));                  // The +1 is to avoid zero-byte allocations.-                 CUDA_SUCCEED(cuMemAlloc(&ctx->global_failure_args, sizeof(int64_t)*($int:max_failure_args+1)));+                 CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure_args, sizeof(int64_t)*($int:max_failure_args+1)));                   $stms:init_kernel_fields @@ -396,7 +396,7 @@                   init_constants(ctx);                  // Clear the free list of any deallocations that occurred while initialising constants.-                 CUDA_SUCCEED(cuda_free_all(&ctx->cuda));+                 CUDA_SUCCEED_FATAL(cuda_free_all(&ctx->cuda));                   futhark_context_sync(ctx); @@ -417,12 +417,12 @@   GC.publicDef_ "context_sync" GC.MiscDecl $ \s ->     ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],       [C.cedecl|int $id:s(struct $id:ctx* ctx) {-                 CUDA_SUCCEED(cuCtxPushCurrent(ctx->cuda.cu_ctx));-                 CUDA_SUCCEED(cuCtxSynchronize());+                 CUDA_SUCCEED_OR_RETURN(cuCtxPushCurrent(ctx->cuda.cu_ctx));+                 CUDA_SUCCEED_OR_RETURN(cuCtxSynchronize());                  if (ctx->failure_is_an_option) {                    // Check for any delayed error.                    typename int32_t failure_idx;-                   CUDA_SUCCEED(+                   CUDA_SUCCEED_OR_RETURN(                      cuMemcpyDtoH(&failure_idx,                                   ctx->global_failure,                                   sizeof(int32_t)));@@ -432,13 +432,13 @@                      // We have to clear global_failure so that the next entry point                      // is not considered a failure from the start.                      typename int32_t no_failure = -1;-                     CUDA_SUCCEED(+                     CUDA_SUCCEED_OR_RETURN(                        cuMemcpyHtoD(ctx->global_failure,                                     &no_failure,                                     sizeof(int32_t)));                       typename int64_t args[$int:max_failure_args+1];-                     CUDA_SUCCEED(+                     CUDA_SUCCEED_OR_RETURN(                        cuMemcpyDtoH(&args,                                     ctx->global_failure_args,                                     sizeof(args)));@@ -448,12 +448,12 @@                      return 1;                    }                  }-                 CUDA_SUCCEED(cuCtxPopCurrent(&ctx->cuda.cu_ctx));+                 CUDA_SUCCEED_OR_RETURN(cuCtxPopCurrent(&ctx->cuda.cu_ctx));                  return 0;                }|]     )    GC.onClear     [C.citem|if (ctx->error == NULL) {-               CUDA_SUCCEED(cuda_free_all(&ctx->cuda));+               CUDA_SUCCEED_NONFATAL(cuda_free_all(&ctx->cuda));              }|]

@@ -81,7 +81,8 @@ where  import Control.Monad.Identity-import Control.Monad.RWS+import Control.Monad.Reader+import Control.Monad.State import Data.Bifunctor (first) import qualified Data.DList as DL import Data.FileEmbed@@ -110,7 +111,8 @@     compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp),     compProfileItems :: DL.DList C.BlockItem,     compClearItems :: DL.DList C.BlockItem,-    compDeclaredMem :: [(VName, Space)]+    compDeclaredMem :: [(VName, Space)],+    compItems :: DL.DList C.BlockItem   }  newCompilerState :: VNameSource -> s -> CompilerState s@@ -127,7 +129,8 @@       compCtxFields = mempty,       compProfileItems = mempty,       compClearItems = mempty,-      compDeclaredMem = mempty+      compDeclaredMem = mempty,+      compItems = mempty     }  -- | In which part of the header file we put the declaration.  This is@@ -288,17 +291,6 @@     envCachedMem :: M.Map C.Exp VName   } -newtype CompilerAcc op s = CompilerAcc-  { accItems :: DL.DList C.BlockItem-  }--instance Semigroup (CompilerAcc op s) where-  CompilerAcc items1 <> CompilerAcc items2 =-    CompilerAcc (items1 <> items2)--instance Monoid (CompilerAcc op s) where-  mempty = CompilerAcc mempty- envOpCompiler :: CompilerEnv op s -> OpCompiler op s envOpCompiler = opsCompiler . envOperations @@ -360,20 +352,13 @@ contextFinalInits = gets compInit  newtype CompilerM op s a-  = CompilerM-      ( RWS-          (CompilerEnv op s)-          (CompilerAcc op s)-          (CompilerState s)-          a-      )+  = CompilerM (ReaderT (CompilerEnv op s) (State (CompilerState s)) a)   deriving     ( Functor,       Applicative,       Monad,       MonadState (CompilerState s),-      MonadReader (CompilerEnv op s),-      MonadWriter (CompilerAcc op s)+      MonadReader (CompilerEnv op s)     )  instance MonadFreshNames (CompilerM op s) where@@ -387,8 +372,9 @@   CompilerM op s a ->   (a, CompilerState s) runCompilerM ops src userstate (CompilerM m) =-  let (x, s, _) = runRWS m (CompilerEnv ops mempty) (newCompilerState src userstate)-   in (x, s)+  runState+    (runReaderT m (CompilerEnv ops mempty))+    (newCompilerState src userstate)  getUserState :: CompilerM op s s getUserState = gets compUserState@@ -405,12 +391,13 @@ collect m = snd <$> collect' m  collect' :: CompilerM op s a -> CompilerM op s (a, [C.BlockItem])-collect' m = pass $ do-  (x, w) <- listen m-  return-    ( (x, DL.toList $ accItems w),-      const w {accItems = mempty}-    )+collect' m = do+  old <- gets compItems+  modify $ \s -> s {compItems = mempty}+  x <- m+  new <- gets compItems+  modify $ \s -> s {compItems = old}+  pure (x, DL.toList new)  -- | Used when we, inside an existing 'CompilerM' action, want to -- generate code for a new function.  Use this so that the compiler@@ -429,10 +416,10 @@       | otherwise = env {envCachedMem = mempty}  item :: C.BlockItem -> CompilerM op s ()-item x = tell $ mempty {accItems = DL.singleton x}+item x = modify $ \s -> s {compItems = DL.snoc (compItems s) x}  items :: [C.BlockItem] -> CompilerM op s ()-items = mapM_ item+items xs = modify $ \s -> s {compItems = DL.append (compItems s) (DL.fromList xs)}  fatMemory :: Space -> CompilerM op s Bool fatMemory ScalarSpace {} = return False@@ -1245,16 +1232,16 @@   [C.BlockItem] ->   Name ->   Function op ->-  CompilerM op s C.Definition-onEntryPoint get_consts fname (Function _ outputs inputs _ results args) = do+  CompilerM op s (Maybe C.Definition)+onEntryPoint _ _ (Function Nothing _ _ _ _ _) = pure Nothing+onEntryPoint get_consts fname (Function (Just ename) outputs inputs _ results args) = do   let out_args = map (\p -> [C.cexp|&$id:(paramName p)|]) outputs       in_args = map (\p -> [C.cexp|$id:(paramName p)|]) inputs    inputdecls <- collect $ mapM_ stubParam inputs   outputdecls <- collect $ mapM_ stubParam outputs -  let entry_point_name = nameToString fname-  entry_point_function_name <- publicName $ "entry_" ++ entry_point_name+  entry_point_function_name <- publicName $ "entry_" ++ nameToString ename    (inputs', unpack_entry_inputs) <- prepareEntryInputs args   let (entry_point_input_params, entry_point_input_checks) = unzip inputs'@@ -1293,7 +1280,7 @@    ops <- asks envOperations -  return+  pure . Just $     [C.cedecl|        int $id:entry_point_function_name            ($ty:ctx_ty *ctx,@@ -1499,7 +1486,7 @@       }   where     Definitions consts (Functions funs) = prog-    entry_funs = filter (functionEntry . snd) funs+    entry_funs = filter (isJust . functionEntry . snd) funs      compileProg' = do       (memstructs, memfuns, memreport) <- unzip3 <$> mapM defineMemorySpace spaces@@ -1513,7 +1500,7 @@        mapM_ earlyDecl memstructs       entry_points <--        mapM (uncurry (onEntryPoint get_consts)) $ filter (functionEntry . snd) funs+        catMaybes <$> mapM (uncurry (onEntryPoint get_consts)) funs        extra @@ -1833,6 +1820,8 @@   where     compileLeaf (ScalarVar src) =       return [C.cexp|$id:src|]+    compileLeaf (Index _ _ Unit __ _) =+      return $ compilePrimValue UnitValue     compileLeaf (Index src (Count iexp) restype DefaultSpace vol) = do       src' <- rawMem src       derefPointer src'@@ -1923,6 +1912,13 @@   args' <- mapM (compilePrimExp f) args   return [C.cexp|$id:(funName (nameFromString h))($args:args')|] +linearCode :: Code op -> [Code op]+linearCode = reverse . go []+  where+    go acc (x :>>: y) =+      go (go acc x) y+    go acc x = x : acc+ compileCode :: Code op -> CompilerM op s () compileCode (Op op) =   join $ asks envOpCompiler <*> pure op@@ -1951,13 +1947,18 @@     [C.cstm|if (ctx->debugging) {           fprintf(ctx->log, "%s\n", $exp:s);        }|]-compileCode c-  | Just (name, vol, t, e, c') <- declareAndSet c = do-    let ct = primTypeToCType t-    e' <- compileExp e-    item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $exp:e';|]-    compileCode c'-compileCode (c1 :>>: c2) = compileCode c1 >> compileCode c2+-- :>>: is treated in a special way to detect declare-set pairs in+-- order to generate prettier code.+compileCode (c1 :>>: c2) = go (linearCode (c1 :>>: c2))+  where+    go (DeclareScalar name vol t : SetScalar dest e : code)+      | name == dest = do+        let ct = primTypeToCType t+        e' <- compileExp e+        item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $exp:e';|]+        go code+    go (x : xs) = compileCode x >> go xs+    go [] = pure () compileCode (Assert e msg (loc, locs)) = do   e' <- compileExp e   err <-@@ -2112,10 +2113,7 @@ blockScope' :: CompilerM op s a -> CompilerM op s (a, [C.BlockItem]) blockScope' m = do   old_allocs <- gets compDeclaredMem-  (x, xs) <- pass $ do-    (x, w) <- listen m-    let xs = DL.toList $ accItems w-    return ((x, xs), const mempty)+  (x, xs) <- collect' m   new_allocs <- gets $ filter (`notElem` old_allocs) . compDeclaredMem   modify $ \s -> s {compDeclaredMem = old_allocs}   releases <- collect $ mapM_ (uncurry unRefMem) new_allocs@@ -2138,21 +2136,6 @@       setMem [C.cexp|*$exp:p|] name space     setRetVal' p (ScalarParam name _) =       stm [C.cstm|*$exp:p = $id:name;|]--declareAndSet :: Code op -> Maybe (VName, Volatility, PrimType, Exp, Code op)-declareAndSet code = do-  (DeclareScalar name vol t, code') <- nextCode code-  (SetScalar dest e, code'') <- nextCode code'-  guard $ name == dest-  Just (name, vol, t, e, code'')--nextCode :: Code op -> Maybe (Code op, Code op)-nextCode (x :>>: y)-  | Just (x_a, x_b) <- nextCode x =-    Just (x_a, x_b <> y)-  | otherwise =-    Just (x, y)-nextCode _ = Nothing  assignmentOperator :: BinOp -> Maybe (VName -> C.Exp -> C.Exp) assignmentOperator Add {} = Just $ \d e -> [C.cexp|$id:d += $exp:e|]

@@ -14,6 +14,7 @@  import Data.FileEmbed import Data.List (unzip5)+import Data.Maybe import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode@@ -305,8 +306,9 @@ cliEntryPoint ::   Name ->   FunctionT a ->-  (C.Definition, C.Initializer)-cliEntryPoint fname (Function _ _ _ _ results args) =+  Maybe (C.Definition, C.Initializer)+cliEntryPoint fname fun@(Function _ _ _ _ results args) = do+  entry_point_name <- nameToString <$> functionEntry fun   let (input_items, pack_input, free_input, free_parsed, input_args) =         unzip5 $ readInputs args @@ -319,7 +321,6 @@       sync_ctx = "futhark_context_sync" :: Name       error_ctx = "futhark_context_get_error" :: Name -      entry_point_name = nameToString fname       cli_entry_point_function_name = "futrts_cli_entry_" ++ entry_point_name       entry_point_function_name = "futhark_entry_" ++ entry_point_name @@ -330,85 +331,86 @@        run_it =         [C.citems|-                  int r;-                  // Run the program once.-                  $stms:pack_input-                  if ($id:sync_ctx(ctx) != 0) {-                    futhark_panic(1, "%s", $id:error_ctx(ctx));-                  };-                  // Only profile last run.-                  if (profile_run) {-                    $id:unpause_profiling(ctx);-                  }-                  t_start = get_wall_time();-                  r = $id:entry_point_function_name(ctx,-                                                    $args:(map addrOf output_vals),-                                                    $args:input_args);-                  if (r != 0) {-                    futhark_panic(1, "%s", $id:error_ctx(ctx));-                  }-                  if ($id:sync_ctx(ctx) != 0) {-                    futhark_panic(1, "%s", $id:error_ctx(ctx));-                  };-                  if (profile_run) {-                    $id:pause_profiling(ctx);-                  }-                  t_end = get_wall_time();-                  long int elapsed_usec = t_end - t_start;-                  if (time_runs && runtime_file != NULL) {-                    fprintf(runtime_file, "%lld\n", (long long) elapsed_usec);-                    fflush(runtime_file);-                  }-                  $stms:free_input-                |]-   in ( [C.cedecl|-  static void $id:cli_entry_point_function_name($ty:ctx_ty *ctx) {-    typename int64_t t_start, t_end;-    int time_runs = 0, profile_run = 0;+                int r;+                // Run the program once.+                $stms:pack_input+                if ($id:sync_ctx(ctx) != 0) {+                  futhark_panic(1, "%s", $id:error_ctx(ctx));+                };+                // Only profile last run.+                if (profile_run) {+                  $id:unpause_profiling(ctx);+                }+                t_start = get_wall_time();+                r = $id:entry_point_function_name(ctx,+                                                  $args:(map addrOf output_vals),+                                                  $args:input_args);+                if (r != 0) {+                  futhark_panic(1, "%s", $id:error_ctx(ctx));+                }+                if ($id:sync_ctx(ctx) != 0) {+                  futhark_panic(1, "%s", $id:error_ctx(ctx));+                };+                if (profile_run) {+                  $id:pause_profiling(ctx);+                }+                t_end = get_wall_time();+                long int elapsed_usec = t_end - t_start;+                if (time_runs && runtime_file != NULL) {+                  fprintf(runtime_file, "%lld\n", (long long) elapsed_usec);+                  fflush(runtime_file);+                }+                $stms:free_input+              |]+  Just+    ( [C.cedecl|+   static void $id:cli_entry_point_function_name($ty:ctx_ty *ctx) {+     typename int64_t t_start, t_end;+     int time_runs = 0, profile_run = 0; -    // We do not want to profile all the initialisation.-    $id:pause_profiling(ctx);+     // We do not want to profile all the initialisation.+     $id:pause_profiling(ctx); -    // Declare and read input.-    set_binary_mode(stdin);-    $items:(mconcat input_items)+     // Declare and read input.+     set_binary_mode(stdin);+     $items:(mconcat input_items) -    if (end_of_input(stdin) != 0) {-      futhark_panic(1, "Expected EOF on stdin after reading input for %s.\n", $string:(quote (pretty fname)));-    }+     if (end_of_input(stdin) != 0) {+       futhark_panic(1, "Expected EOF on stdin after reading input for %s.\n", $string:(quote (pretty fname)));+     } -    $items:output_decls+     $items:output_decls -    // Warmup run-    if (perform_warmup) {-      $items:run_it-      $stms:free_outputs-    }-    time_runs = 1;-    // Proper run.-    for (int run = 0; run < num_runs; run++) {-      // Only profile last run.-      profile_run = run == num_runs -1;-      $items:run_it-      if (run < num_runs-1) {-        $stms:free_outputs-      }-    }+     // Warmup run+     if (perform_warmup) {+       $items:run_it+       $stms:free_outputs+     }+     time_runs = 1;+     // Proper run.+     for (int run = 0; run < num_runs; run++) {+       // Only profile last run.+       profile_run = run == num_runs -1;+       $items:run_it+       if (run < num_runs-1) {+         $stms:free_outputs+       }+     } -    // Free the parsed input.-    $stms:free_parsed+     // Free the parsed input.+     $stms:free_parsed -    // Print the final result.-    if (binary_output) {-      set_binary_mode(stdout);-    }-    $stms:printstms+     // Print the final result.+     if (binary_output) {+       set_binary_mode(stdout);+     }+     $stms:printstms -    $stms:free_outputs-  }|],-        [C.cinit|{ .name = $string:entry_point_name,-                      .fun = $id:cli_entry_point_function_name }|]-      )+     $stms:free_outputs+   }|],+      [C.cinit|{ .name = $string:entry_point_name,+                       .fun = $id:cli_entry_point_function_name }|]+    )  {-# NOINLINE cliDefs #-} @@ -421,7 +423,7 @@       option_parser =         generateOptionParser "parse_options" $ genericOptions ++ options       (cli_entry_point_decls, entry_point_inits) =-        unzip $ map (uncurry cliEntryPoint) funs+        unzip $ mapMaybe (uncurry cliEntryPoint) funs    in [C.cunit| $esc:("#include <getopt.h>") $esc:("#include <ctype.h>")

@@ -15,6 +15,7 @@ import Data.Bifunctor (first, second) import Data.FileEmbed import qualified Data.Map as M+import Data.Maybe import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode@@ -184,17 +185,15 @@  entryTypeBoilerplate :: Functions a -> ([C.Initializer], [C.Definition]) entryTypeBoilerplate (Functions funs) =-  second concat $-    unzip $-      M.elems $-        M.fromList $-          map valueDescBoilerplate $-            concatMap (functionExternalValues . snd) $-              filter (functionEntry . snd) funs+  second concat . unzip . M.elems . M.fromList . map valueDescBoilerplate+    . concatMap (functionExternalValues . snd)+    . filter (isJust . functionEntry . snd)+    $ funs -oneEntryBoilerplate :: (Name, Function a) -> ([C.Definition], C.Initializer)-oneEntryBoilerplate (name, fun) =-  let entry_f = "futhark_entry_" ++ pretty name+oneEntryBoilerplate :: (Name, Function a) -> Maybe ([C.Definition], C.Initializer)+oneEntryBoilerplate (name, fun) = do+  ename <- functionEntry fun+  let entry_f = "futhark_entry_" ++ pretty ename       call_f = "call_" ++ pretty name       out_types = functionResult fun       in_types = functionArgs fun@@ -206,7 +205,8 @@       (in_items, in_args)         | null in_types = ([C.citems|(void)ins;|], mempty)         | otherwise = unzip $ zipWith loadIn [0 ..] in_types-   in ( [C.cunit|+  pure+    ( [C.cunit|                 struct type* $id:out_types_name[] = {                   $inits:(map typeStructInit out_types),                   NULL@@ -221,13 +221,13 @@                   return $id:entry_f(ctx, $args:out_args, $args:in_args);                 }                 |],-        [C.cinit|{-            .name = $string:(pretty name),+      [C.cinit|{+            .name = $string:(pretty ename),             .f = $id:call_f,             .in_types = $id:in_types_name,             .out_types = $id:out_types_name             }|]-      )+    )   where     typeStructInit t = [C.cinit|&$id:(typeStructName t)|] @@ -245,7 +245,7 @@  entryBoilerplate :: Functions a -> ([C.Definition], [C.Initializer]) entryBoilerplate (Functions funs) =-  first concat $ unzip $ map oneEntryBoilerplate $ filter (functionEntry . snd) funs+  first concat $ unzip $ mapMaybe oneEntryBoilerplate funs  mkBoilerplate ::   Functions a ->

@@ -327,7 +327,7 @@ opaqueDefs :: Imp.Functions a -> M.Map String [PyExp] opaqueDefs (Imp.Functions funs) =   mconcat . map evd . concatMap (functionExternalValues . snd) $-    filter (Imp.functionEntry . snd) funs+    filter (isJust . Imp.functionEntry . snd) funs   where     evd Imp.TransparentValue {} = mempty     evd (Imp.OpaqueValue name vds) =@@ -365,28 +365,23 @@ compileProg mode class_name constructor imports defines ops userstate sync options prog = do   src <- getNameSource   let prog' = runCompilerM ops src userstate compileProg'-      maybe_shebang =-        case mode of-          ToLibrary -> ""-          _ -> "#!/usr/bin/env python3\n"   return $-    maybe_shebang-      ++ pretty-        ( PyProg $-            imports-              ++ [ Import "argparse" Nothing,-                   Assign (Var "sizes") $ Dict []-                 ]-              ++ defines-              ++ [ Escape pyValues,-                   Escape pyFunctions,-                   Escape pyPanic,-                   Escape pyTuning,-                   Escape pyUtility,-                   Escape pyServer-                 ]-              ++ prog'-        )+    pretty+      ( PyProg $+          imports+            ++ [ Import "argparse" Nothing,+                 Assign (Var "sizes") $ Dict []+               ]+            ++ defines+            ++ [ Escape pyValues,+                 Escape pyFunctions,+                 Escape pyPanic,+                 Escape pyTuning,+                 Escape pyUtility,+                 Escape pyServer+               ]+            ++ prog'+      )   where     Imp.Definitions consts (Imp.Functions funs) = prog     compileProg' = withConstantSubsts consts $ do@@ -400,10 +395,7 @@       case mode of         ToLibrary -> do           (entry_points, entry_point_types) <--            unzip-              <$> mapM-                (compileEntryFun sync DoNotReturnTiming)-                (filter (Imp.functionEntry . snd) funs)+            unzip . catMaybes <$> mapM (compileEntryFun sync DoNotReturnTiming) funs           return             [ ClassDef $                 Class class_name $@@ -415,10 +407,7 @@             ]         ToServer -> do           (entry_points, entry_point_types) <--            unzip-              <$> mapM-                (compileEntryFun sync ReturnTiming)-                (filter (Imp.functionEntry . snd) funs)+            unzip . catMaybes <$> mapM (compileEntryFun sync ReturnTiming) funs           return $             parse_options_server               ++ [ ClassDef@@ -437,10 +426,7 @@         ToExecutable -> do           let classinst = Assign (Var "self") $ simpleCall class_name []           (entry_point_defs, entry_point_names, entry_points) <--            unzip3-              <$> mapM-                (callEntryFun sync)-                (filter (Imp.functionEntry . snd) funs)+            unzip3 . catMaybes <$> mapM (callEntryFun sync) funs           return $             parse_options_executable               ++ ClassDef@@ -794,8 +780,7 @@   CompilerM     op     s-    ( String,-      [String],+    ( [String],       [PyStmt],       [PyStmt],       [PyStmt],@@ -857,8 +842,7 @@         ]    return-    ( nameToString fname,-      map extValueDescName args,+    ( map extValueDescName args,       prepareIn,       call argexps_lib,       call argexps_bin,@@ -891,40 +875,43 @@   [PyStmt] ->   ReturnTiming ->   (Name, Imp.Function op) ->-  CompilerM op s (PyFunDef, (PyExp, PyExp))-compileEntryFun sync timing entry = do-  (fname', params, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry-  let (maybe_sync, ret) =-        case timing of-          DoNotReturnTiming ->-            ( [],-              Return $ tupleOrSingle $ map snd res-            )-          ReturnTiming ->-            ( sync,-              Return $-                Tuple-                  [ Var "runtime",-                    tupleOrSingle $ map snd res-                  ]-            )-      (pts, rts) = entryTypes $ snd entry+  CompilerM op s (Maybe (PyFunDef, (PyExp, PyExp)))+compileEntryFun sync timing entry+  | Just ename <- Imp.functionEntry $ snd entry = do+    (params, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry+    let (maybe_sync, ret) =+          case timing of+            DoNotReturnTiming ->+              ( [],+                Return $ tupleOrSingle $ map snd res+              )+            ReturnTiming ->+              ( sync,+                Return $+                  Tuple+                    [ Var "runtime",+                      tupleOrSingle $ map snd res+                    ]+              )+        (pts, rts) = entryTypes $ snd entry -      do_run =-        Assign (Var "time_start") (simpleCall "time.time" []) :-        body_lib ++ maybe_sync-          ++ [ Assign (Var "runtime") $-                 BinOp-                   "-"-                   (toMicroseconds (simpleCall "time.time" []))-                   (toMicroseconds (Var "time_start"))-             ]+        do_run =+          Assign (Var "time_start") (simpleCall "time.time" []) :+          body_lib ++ maybe_sync+            ++ [ Assign (Var "runtime") $+                   BinOp+                     "-"+                     (toMicroseconds (simpleCall "time.time" []))+                     (toMicroseconds (Var "time_start"))+               ] -  return-    ( Def fname' ("self" : params) $-        prepareIn ++ do_run ++ prepareOut ++ sync ++ [ret],-      (String fname', Tuple [List (map String pts), List (map String rts)])-    )+    pure $+      Just+        ( Def (nameToString ename) ("self" : params) $+            prepareIn ++ do_run ++ prepareOut ++ sync ++ [ret],+          (String (nameToString ename), Tuple [List (map String pts), List (map String rts)])+        )+  | otherwise = pure Nothing  entryTypes :: Imp.Function op -> ([String], [String]) entryTypes func =@@ -940,9 +927,10 @@ callEntryFun ::   [PyStmt] ->   (Name, Imp.Function op) ->-  CompilerM op s (PyFunDef, String, PyExp)-callEntryFun pre_timing entry@(fname, Imp.Function _ _ _ _ _ decl_args) = do-  (_, _, prepare_in, _, body_bin, _, res, prepare_run) <- prepareEntry entry+  CompilerM op s (Maybe (PyFunDef, String, PyExp))+callEntryFun _ (_, Imp.Function Nothing _ _ _ _ _) = pure Nothing+callEntryFun pre_timing entry@(fname, Imp.Function (Just ename) _ _ _ _ decl_args) = do+  (_, prepare_in, _, body_bin, _, res, prepare_run) <- prepareEntry entry    let str_input = map readInput decl_args       end_of_input = [Exp $ simpleCall "end_of_input" [String $ pretty fname]]@@ -965,15 +953,16 @@    let fname' = "entry_" ++ nameToString fname -  return-    ( Def fname' [] $-        str_input ++ end_of_input ++ prepare_in-          ++ [Try [do_warmup_run, do_num_runs] [except']]-          ++ [close_runtime_file]-          ++ str_output,-      nameToString fname,-      Var fname'-    )+  pure $+    Just+      ( Def fname' [] $+          str_input ++ end_of_input ++ prepare_in+            ++ [Try [do_warmup_run, do_num_runs] [except']]+            ++ [close_runtime_file]+            ++ str_output,+        nameToString ename,+        Var fname'+      )  addTiming :: [PyStmt] -> ([PyStmt], PyStmt) addTiming statements =@@ -1160,6 +1149,8 @@   where     compileLeaf (Imp.ScalarVar vname) =       compileVar vname+    compileLeaf (Imp.Index _ _ Unit _ _) =+      return $ compilePrimValue UnitValue     compileLeaf (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) =       join $         asks envReadScalar

@@ -533,7 +533,7 @@    e' <- GC.compileExp e -  let lexical = lexicalMemoryUsage $ Function False [] params seq_code [] []+  let lexical = lexicalMemoryUsage $ Function Nothing [] params seq_code [] []    fstruct <-     prepareTaskStruct "task" free_args free_ctypes retval_args retval_ctypes@@ -558,7 +558,7 @@   -- Generate the nested segop function if available   fnpar_task <- case par_task of     Just (ParallelTask nested_code nested_tid) -> do-      let lexical_nested = lexicalMemoryUsage $ Function False [] params nested_code [] []+      let lexical_nested = lexicalMemoryUsage $ Function Nothing [] params nested_code [] []       fnpar_task <- generateParLoopFn lexical_nested (name ++ "_nested_task") nested_code fstruct free retval nested_tid nsubtask       GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|]       return $ zip [fnpar_task] [True]@@ -583,7 +583,7 @@    let lexical =         lexicalMemoryUsage $-          Function False [] free (prebody <> body) [] []+          Function Nothing [] free (prebody <> body) [] []    fstruct <-     prepareTaskStruct (s' ++ "_parloop_struct") free_args free_ctypes mempty mempty

@@ -102,9 +102,11 @@   { defConsts :: Constants a,     defFuns :: Functions a   }+  deriving (Show)  -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)]+  deriving (Show)  instance Semigroup (Functions a) where   Functions x <> Functions y = Functions $ x ++ y@@ -120,6 +122,7 @@     -- contain declarations of the names defined in 'constsDecl'.     constsInit :: Code a   }+  deriving (Show)  -- | Since the core language does not care for signedness, but the -- source language does, entry point input/output information has@@ -154,7 +157,7 @@ -- and results.  The latter are only used if the function is an entry -- point. data FunctionT a = Function-  { functionEntry :: Bool,+  { functionEntry :: Maybe Name,     functionOutput :: [Param],     functionInput :: [Param],     functionBody :: Code a,

@@ -91,6 +91,7 @@     dPrimV_,     dPrimV,     dPrimVE,+    dIndexSpace,     sFor,     sWhile,     sComment,@@ -144,8 +145,10 @@ import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.IR.SOACS (SOACS) import Futhark.Util+import Futhark.Util.IntegralExp import Futhark.Util.Loc (noLoc) import Language.Futhark.Warnings+import Prelude hiding (quot)  -- | How to compile an t'Op'. type OpCompiler lore r op = Pattern lore -> Op lore -> ImpM lore r op ()@@ -647,12 +650,17 @@   FunDef lore ->   ImpM lore r op () compileFunDef (FunDef entry _ fname rettype params body) =-  local (\env -> env {envFunction = Just fname}) $ do+  local (\env -> env {envFunction = name_entry `mplus` Just fname}) $ do     ((outparams, inparams, results, args), body') <- collect' compile-    emitFunction fname $ Imp.Function (isJust entry) outparams inparams body' results args+    emitFunction fname $ Imp.Function name_entry outparams inparams body' results args   where-    params_entry = maybe (replicate (length params) TypeDirect) fst entry-    ret_entry = maybe (replicate (length rettype) TypeDirect) snd entry+    (name_entry, params_entry, ret_entry) = case entry of+      Nothing ->+        ( Nothing,+          replicate (length params) TypeDirect,+          replicate (length rettype) TypeDirect+        )+      Just (x, y, z) -> (Just x, y, z)     compile = do       (inparams, arrayds, args) <- compileInParams params params_entry       (results, outparams, Destination _ dests) <- compileOutParams rettype ret_entry@@ -1837,10 +1845,37 @@   body <- collect $ do     mapM_ addParam $ outputs ++ inputs     m-  emitFunction fname $ Imp.Function False outputs inputs body [] []+  emitFunction fname $ Imp.Function Nothing outputs inputs body [] []   where     addParam (Imp.MemParam name space) =       addVar name $ MemVar Nothing $ MemEntry space     addParam (Imp.ScalarParam name bt) =       addVar name $ ScalarVar Nothing $ ScalarEntry bt     newFunction env = env {envFunction = Just fname}++dSlices :: [Imp.TExp Int64] -> ImpM lore r op [Imp.TExp Int64]+dSlices = fmap (drop 1 . snd) . dSlices'+  where+    dSlices' [] = pure (1, [1])+    dSlices' (n : ns) = do+      (prod, ns') <- dSlices' ns+      n' <- dPrimVE "slice" $ n * prod+      pure (n', n' : ns')++-- | @dIndexSpace f dims i@ computes a list of indices into an+-- array with dimension @dims@ given the flat index @i@.  The+-- resulting list will have the same size as @dims@.  Intermediate+-- results are passed to @f@.+dIndexSpace ::+  [(VName, Imp.TExp Int64)] ->+  Imp.TExp Int64 ->+  ImpM lore r op ()+dIndexSpace vs_ds j = do+  slices <- dSlices (map snd vs_ds)+  loop (zip (map fst vs_ds) slices) j+  where+    loop ((v, size) : rest) i = do+      dPrimV_ v (i `quot` size)+      i' <- dPrimVE "remnant" $ i - Imp.vi64 v * size+      loop rest i'+    loop _ _ = pure ()

@@ -315,7 +315,7 @@  mapTransposeFunction :: PrimType -> Imp.Function mapTransposeFunction bt =-  Imp.Function False [] params transpose_code [] []+  Imp.Function Nothing [] params transpose_code [] []   where     params =       [ memparam destmem,

@@ -1145,5 +1145,7 @@                 map Imp.vi64 $                   map fst segment_dims ++ [subhistogram_id, bucket_id] ++ vector_ids               )++  emit $ Imp.DebugPrint "" Nothing   where     segment_dims = init $ unSegSpace space

@@ -28,21 +28,22 @@       num_groups' = toInt64Exp <$> segNumGroups lvl       group_size' = toInt64Exp <$> segGroupSize lvl +  emit $ Imp.DebugPrint "\n# SegMap" Nothing   case lvl of     SegThread {} -> do-      emit $ Imp.DebugPrint "\n# SegMap" Nothing       let virt_num_groups =             sExt32 $ product dims' `divUp` unCount group_size'       sKernelThread "segmap" num_groups' group_size' (segFlat space) $         virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do           local_tid <- kernelLocalThreadId . kernelConstants <$> askEnv-          let global_tid =-                sExt64 group_id * sExt64 (unCount group_size')-                  + sExt64 local_tid -          zipWithM_ dPrimV_ is $-            map sExt64 $ unflattenIndex (map sExt64 dims') global_tid+          global_tid <-+            dPrimVE "global_tid" $+              sExt64 group_id * sExt64 (unCount group_size')+                + sExt64 local_tid +          dIndexSpace (zip is dims') global_tid+           sWhen (isActive $ unSegSpace space) $             compileStms mempty (kernelBodyStms kbody) $               zipWithM_ (compileThreadResult space) (patternElements pat) $@@ -52,8 +53,9 @@         let virt_num_groups = sExt32 $ product dims'         precomputeSegOpIDs (kernelBodyStms kbody) $           virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do-            zipWithM_ dPrimV_ is $ unflattenIndex dims' $ sExt64 group_id+            dIndexSpace (zip is dims') $ sExt64 group_id              compileStms mempty (kernelBodyStms kbody) $               zipWithM_ (compileGroupResult space) (patternElements pat) $                 kernelBodyResult kbody+  emit $ Imp.DebugPrint "" Nothing

@@ -209,12 +209,8 @@             `divUp` Imp.elements (sExt64 (kernelNumThreads constants))      slugs <--      mapM-        ( segBinOpSlug-            (kernelLocalThreadId constants)-            (kernelGroupId constants)-        )-        $ zip3 reds reds_arrs reds_group_res_arrs+      mapM (segBinOpSlug (kernelLocalThreadId constants) (kernelGroupId constants)) $+        zip3 reds reds_arrs reds_group_res_arrs     reds_op_renamed <-       reductionStageOne         constants@@ -229,45 +225,31 @@     let segred_pes =           chunks (map (length . segBinOpNeutral) reds) $             patternElements segred_pat-    forM_-      ( zip7-          reds-          reds_arrs-          reds_group_res_arrs-          segred_pes-          slugs-          reds_op_renamed-          [0 ..]-      )-      $ \( SegBinOp _ red_op nes _,-           red_arrs,-           group_res_arrs,-           pes,-           slug,-           red_op_renamed,-           i-           ) -> do-          let (red_x_params, red_y_params) = splitAt (length nes) $ lambdaParams red_op-          reductionStageTwo-            constants-            pes-            (kernelGroupId constants)-            0-            [0]-            0-            (sExt64 $ kernelNumGroups constants)-            slug-            red_x_params-            red_y_params-            red_op_renamed-            nes-            1-            counter-            (fromInteger i)-            sync_arr-            group_res_arrs-            red_arrs+    forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0 ..]) $+      \(SegBinOp _ red_op nes _, red_arrs, group_res_arrs, pes, slug, red_op_renamed, i) -> do+        let (red_x_params, red_y_params) = splitAt (length nes) $ lambdaParams red_op+        reductionStageTwo+          constants+          pes+          (kernelGroupId constants)+          0+          [0]+          0+          (sExt64 $ kernelNumGroups constants)+          slug+          red_x_params+          red_y_params+          red_op_renamed+          nes+          1+          counter+          (fromInteger i)+          sync_arr+          group_res_arrs+          red_arrs +  emit $ Imp.DebugPrint "" Nothing+ smallSegmentsReduction ::   Pattern KernelsMem ->   Count NumGroups SubExp ->@@ -315,7 +297,7 @@               + (sExt64 group_id' * sExt64 segments_per_group)           index_within_segment = ltid `rem` segment_size -      zipWithM_ dPrimV_ (init gtids) $ unflattenIndex (init dims') segment_index+      dIndexSpace (zip (init gtids) (init dims')) segment_index       dPrimV_ (last gtids) index_within_segment        let out_of_bounds =@@ -375,6 +357,8 @@       -- local memory array first thing in the next iteration.       sOp $ Imp.Barrier Imp.FenceLocal +  emit $ Imp.DebugPrint "" Nothing+ largeSegmentsReduction ::   Pattern KernelsMem ->   Count NumGroups SubExp ->@@ -458,9 +442,7 @@             `rem` (sExt64 (unCount group_size') * groups_per_segment)        let first_group_for_segment = sExt64 flat_segment_id * groups_per_segment--      zipWithM_ dPrimV_ segment_gtids $-        unflattenIndex (init dims') $ sExt64 flat_segment_id+      dIndexSpace (zip segment_gtids (init dims')) $sExt64 flat_segment_id       dPrim_ (last gtids) int64       let num_elements = Imp.elements $ toInt64Exp w @@ -483,45 +465,29 @@               patternElements segred_pat            multiple_groups_per_segment =-            forM_-              ( zip7-                  reds-                  reds_arrs-                  reds_group_res_arrs-                  segred_pes-                  slugs-                  reds_op_renamed-                  [0 ..]-              )-              $ \( SegBinOp _ red_op nes _,-                   red_arrs,-                   group_res_arrs,-                   pes,-                   slug,-                   red_op_renamed,-                   i-                   ) -> do-                  let (red_x_params, red_y_params) =-                        splitAt (length nes) $ lambdaParams red_op-                  reductionStageTwo-                    constants-                    pes-                    group_id-                    flat_segment_id-                    (map Imp.vi64 segment_gtids)-                    (sExt64 first_group_for_segment)-                    groups_per_segment-                    slug-                    red_x_params-                    red_y_params-                    red_op_renamed-                    nes-                    (fromIntegral num_counters)-                    counter-                    (fromInteger i)-                    sync_arr-                    group_res_arrs-                    red_arrs+            forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0 ..]) $+              \(SegBinOp _ red_op nes _, red_arrs, group_res_arrs, pes, slug, red_op_renamed, i) -> do+                let (red_x_params, red_y_params) =+                      splitAt (length nes) $ lambdaParams red_op+                reductionStageTwo+                  constants+                  pes+                  group_id+                  flat_segment_id+                  (map Imp.vi64 segment_gtids)+                  (sExt64 first_group_for_segment)+                  groups_per_segment+                  slug+                  red_x_params+                  red_y_params+                  red_op_renamed+                  nes+                  (fromIntegral num_counters)+                  counter+                  (fromInteger i)+                  sync_arr+                  group_res_arrs+                  red_arrs            one_group_per_segment =             comment "first thread in group saves final result to memory" $@@ -531,6 +497,8 @@                     copyDWIMFix (patElemName v) (map Imp.vi64 segment_gtids) (Var acc) acc_is        sIf (groups_per_segment .==. 1) one_group_per_segment multiple_groups_per_segment++  emit $ Imp.DebugPrint "" Nothing  -- Careful to avoid division by zero here.  We have at least one group -- per segment.

@@ -45,7 +45,7 @@   kstms' <- mapM renameStm kstms   collect $ do     emit $ Imp.DebugPrint "SegMap fbody" Nothing-    zipWithM_ dPrimV_ is $ map sExt64 $ unflattenIndex ns' $ tvExp flat_idx+    dIndexSpace (zip is ns') $ tvExp flat_idx     compileStms (freeIn kres) kstms' $       zipWithM_ (writeResult is) (patternElements pat) kres 

@@ -42,7 +42,7 @@ mapTransposeFunction :: Name -> PrimType -> Function op mapTransposeFunction fname pt =   Function-    False+    Nothing     []     params     ( mconcat

@@ -6,11 +6,10 @@ module Futhark.Compiler   ( runPipelineOnProgram,     runCompilerOnProgram,-    FutharkConfig (..),-    newFutharkConfig,     dumpError,     handleWarnings,     module Futhark.Compiler.Program,+    module Futhark.Compiler.Config,     readProgram,     readProgramOrDie,     readUntypedProgram,@@ -23,6 +22,7 @@ import Data.Bifunctor (first) import qualified Data.Text.IO as T import qualified Futhark.Analysis.Alias as Alias+import Futhark.Compiler.Config import Futhark.Compiler.Program import Futhark.IR import qualified Futhark.IR.SOACS as I@@ -38,36 +38,6 @@ import System.Exit (ExitCode (..), exitWith) import System.IO --- | The compiler configuration.  This only contains options related--- to core compiler functionality, such as reading the initial program--- and running passes.  Options related to code generation are handled--- elsewhere.-data FutharkConfig = FutharkConfig-  { futharkVerbose :: (Verbosity, Maybe FilePath),-    -- | Warn if True.-    futharkWarn :: Bool,-    -- | If true, error on any warnings.-    futharkWerror :: Bool,-    -- | If True, ignore @unsafe@.-    futharkSafe :: Bool,-    -- | Additional functions that should be exposed as entry points.-    futharkEntryPoints :: [Name],-    -- | If false, disable type-checking-    futharkTypeCheck :: Bool-  }---- | The default compiler configuration.-newFutharkConfig :: FutharkConfig-newFutharkConfig =-  FutharkConfig-    { futharkVerbose = (NotVerbose, Nothing),-      futharkWarn = True,-      futharkWerror = False,-      futharkSafe = False,-      futharkEntryPoints = [],-      futharkTypeCheck = True-    }- -- | Print a compiler error to stdout.  The 'FutharkConfig' controls -- to which degree auxiliary information (e.g. the failing program) is -- also printed.@@ -137,9 +107,7 @@         <$> readProgram (futharkEntryPoints config) file    putNameSource namesrc-  when (pipelineVerbose pipeline_config) $-    logMsg ("Internalising program" :: String)-  int_prog <- internaliseProg (futharkSafe config) prog_imports+  int_prog <- internaliseProg config prog_imports   when (pipelineVerbose pipeline_config) $     logMsg ("Type-checking internalised program" :: String)   typeCheckInternalProgram int_prog

@@ -19,7 +19,6 @@ import Futhark.Pipeline import Futhark.Util.Options import System.FilePath-import System.IO  -- | Run a parameterised Futhark compiler, where @cfg@ is a user-given -- configuration type.  Call this from @main@.@@ -47,16 +46,12 @@   -- | Command line arguments.   [String] ->   IO ()-compilerMain cfg cfg_opts name desc pipeline doIt prog args = do-  hSetEncoding stdout utf8-  hSetEncoding stderr utf8+compilerMain cfg cfg_opts name desc pipeline doIt =   mainWithOptions     (newCompilerConfig cfg)     (commandLineOptions ++ map wrapOption cfg_opts)     "options... <program.fut>"     inspectNonOptions-    prog-    args   where     inspectNonOptions [file] config = Just $ compile config file     inspectNonOptions _ _ = Nothing@@ -137,7 +132,7 @@       "Ignore 'unsafe' in code.",     Option       []-      ["entry-points"]+      ["entry-point"]       ( ReqArg           ( \arg -> Right $ \config ->               config

@@ -0,0 +1,39 @@+module Futhark.Compiler.Config+  ( FutharkConfig (..),+    newFutharkConfig,+    Verbosity (..),+  )+where++import Futhark.IR+import Futhark.Pipeline++-- | The compiler configuration.  This only contains options related+-- to core compiler functionality, such as reading the initial program+-- and running passes.  Options related to code generation are handled+-- elsewhere.+data FutharkConfig = FutharkConfig+  { futharkVerbose :: (Verbosity, Maybe FilePath),+    -- | Warn if True.+    futharkWarn :: Bool,+    -- | If true, error on any warnings.+    futharkWerror :: Bool,+    -- | If True, ignore @unsafe@.+    futharkSafe :: Bool,+    -- | Additional functions that should be exposed as entry points.+    futharkEntryPoints :: [Name],+    -- | If false, disable type-checking+    futharkTypeCheck :: Bool+  }++-- | The default compiler configuration.+newFutharkConfig :: FutharkConfig+newFutharkConfig =+  FutharkConfig+    { futharkVerbose = (NotVerbose, Nothing),+      futharkWarn = True,+      futharkWerror = False,+      futharkSafe = False,+      futharkEntryPoints = [],+      futharkTypeCheck = True+    }

@@ -31,6 +31,7 @@ import Language.Futhark.Semantic import qualified Language.Futhark.TypeChecker as E import Language.Futhark.Warnings+import System.FilePath (normalise) import qualified System.FilePath.Posix as Posix  newtype ReaderState = ReaderState@@ -161,8 +162,9 @@   [(ImportName, E.UncheckedProg)] setEntryPoints extra_eps fps = map onProg   where+    fps' = map normalise fps     onProg (name, prog)-      | includeToFilePath name `elem` fps =+      | includeToFilePath name `elem` fps' =         (name, prog {E.progDecs = map onDec (E.progDecs prog)})       | otherwise =         (name, prog)

@@ -510,7 +510,11 @@     pResult = braces $ pSubExp `sepBy` pComma  pEntry :: Parser EntryPoint-pEntry = parens $ (,) <$> pEntryPointTypes <* pComma <*> pEntryPointTypes+pEntry =+  parens $+    (,,) <$> (nameFromString <$> pStringLiteral)+      <* pComma <*> pEntryPointTypes+      <* pComma <*> pEntryPointTypes   where     pEntryPointTypes = braces (pEntryPointType `sepBy` pComma)     pEntryPointType =

@@ -287,7 +287,7 @@ instance PrettyLore lore => Pretty (Lambda lore) where   ppr (Lambda [] (Body _ stms []) []) | stms == mempty = text "nilFn"   ppr (Lambda params body rettype) =-    text "\\" <> ppTuple' params+    text "\\" <+> ppTuple' params       <+/> colon <+> ppTuple' rettype <+> text "->"       </> indent 2 (ppr body) @@ -307,9 +307,13 @@     where       fun = case entry of         Nothing -> "fun"-        Just (p_entry, ret_entry) ->+        Just (p_name, p_entry, ret_entry) ->           "entry"-            <> nestedBlock "(" ")" (ppTuple' p_entry <> comma </> ppTuple' ret_entry)+            <> parens+              ( "\"" <> ppr p_name <> "\"" <> comma+                  </> ppTuple' p_entry <> comma+                  </> ppTuple' ret_entry+              )  instance PrettyLore lore => Pretty (Prog lore) where   ppr (Prog consts funs) =

@@ -121,6 +121,8 @@     ceilFloat,     floorDouble,     floorFloat,+    hypot,+    hypotf,     lgamma,     lgammaf,     roundDouble,@@ -626,7 +628,8 @@  -- | @abs(-2.0) = 2.0@. doFAbs :: FloatValue -> FloatValue-doFAbs v = floatValue (floatValueType v) $ abs $ floatToDouble v+doFAbs (Float32Value x) = Float32Value $ abs x+doFAbs (Float64Value x) = Float64Value $ abs x  -- | @ssignum(-2)@ = -1. doSSignum :: IntValue -> IntValue@@ -1229,7 +1232,7 @@           FloatType Float32,           \case             [FloatValue (Float32Value x), FloatValue (Float32Value y)] ->-              Just $ FloatValue $ Float32Value $ sqrt (x * x + y * y)+              Just $ FloatValue $ Float32Value $ hypotf x y             _ -> Nothing         )       ),@@ -1238,7 +1241,7 @@           FloatType Float64,           \case             [FloatValue (Float64Value x), FloatValue (Float64Value y)] ->-              Just $ FloatValue $ Float64Value $ sqrt (x * x + y * y)+              Just $ FloatValue $ Float64Value $ hypot x y             _ -> Nothing         )       ),

@@ -514,7 +514,7 @@ -- | Information about the parameters and return value of an entry -- point.  The first element is for parameters, the second for return -- value.-type EntryPoint = ([EntryPointType], [EntryPointType])+type EntryPoint = (Name, [EntryPointType], [EntryPointType])  -- | Every entry point argument and return value has an annotation -- indicating how it maps to the original source program type.

@@ -1,2133 +1,44 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}---- |------ This module implements a transformation from source to core--- Futhark.-module Futhark.Internalise (internaliseProg) where--import Control.Monad.Reader-import Data.List (find, intercalate, intersperse, transpose)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Strict as M-import qualified Data.Set as S-import Futhark.IR.SOACS as I hiding (stmPattern)-import Futhark.Internalise.AccurateSizes-import Futhark.Internalise.Bindings-import Futhark.Internalise.Defunctionalise as Defunctionalise-import Futhark.Internalise.Defunctorise as Defunctorise-import Futhark.Internalise.Lambdas-import Futhark.Internalise.LiftLambdas as LiftLambdas-import Futhark.Internalise.Monad as I-import Futhark.Internalise.Monomorphise as Monomorphise-import Futhark.Internalise.TypesValues-import Futhark.Transform.Rename as I-import Futhark.Util (splitAt3)-import Futhark.Util.Pretty (prettyOneLine)-import Language.Futhark as E hiding (TypeArg)-import Language.Futhark.Semantic (Imports)---- | Convert a program in source Futhark to a program in the Futhark--- core language.-internaliseProg ::-  MonadFreshNames m =>-  Bool ->-  Imports ->-  m (I.Prog SOACS)-internaliseProg always_safe prog = do-  prog_decs <- Defunctorise.transformProg prog-  prog_decs' <- Monomorphise.transformProg prog_decs-  prog_decs'' <- LiftLambdas.transformProg prog_decs'-  prog_decs''' <- Defunctionalise.transformProg prog_decs''-  (consts, funs) <--    runInternaliseM always_safe (internaliseValBinds prog_decs''')-  I.renameProg $ I.Prog consts funs--internaliseAttr :: E.AttrInfo -> Attr-internaliseAttr (E.AttrAtom v) = I.AttrAtom v-internaliseAttr (E.AttrComp f attrs) = I.AttrComp f $ map internaliseAttr attrs--internaliseAttrs :: [E.AttrInfo] -> Attrs-internaliseAttrs = mconcat . map (oneAttr . internaliseAttr)--internaliseValBinds :: [E.ValBind] -> InternaliseM ()-internaliseValBinds = mapM_ internaliseValBind--internaliseFunName :: VName -> Name-internaliseFunName = nameFromString . pretty--internaliseValBind :: E.ValBind -> InternaliseM ()-internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ attrs loc) = do-  localConstsScope $-    bindingFParams tparams params $ \shapeparams params' -> do-      let shapenames = map I.paramName shapeparams--      msg <- case retdecl of-        Just dt ->-          errorMsg-            . ("Function return value does not match shape of type " :)-            <$> typeExpForError dt-        Nothing -> return $ errorMsg ["Function return value does not match shape of declared return type."]--      (body', rettype') <- buildBody $ do-        body_res <- internaliseExp (baseString fname <> "_res") body-        rettype_bad <--          internaliseReturnType rettype =<< mapM subExpType body_res-        let rettype' = zeroExts rettype_bad-        body_res' <--          ensureResultExtShape msg loc (map I.fromDecl rettype') body_res-        pure (body_res', rettype')--      let all_params = shapeparams ++ concat params'--      let fd =-            I.FunDef-              Nothing-              (internaliseAttrs attrs)-              (internaliseFunName fname)-              rettype'-              all_params-              body'--      if null params'-        then bindConstant fname fd-        else-          bindFunction-            fname-            fd-            ( shapenames,-              map declTypeOf $ concat params',-              all_params,-              applyRetType rettype' all_params-            )--  case entry of-    Just (Info entry') -> generateEntryPoint entry' fb-    Nothing -> return ()-  where-    zeroExts ts = generaliseExtTypes ts ts--generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM ()-generateEntryPoint (E.EntryPoint e_paramts e_rettype) vb = localConstsScope $ do-  let (E.ValBind _ ofname _ (Info (rettype, _)) tparams params _ _ attrs loc) = vb-  bindingFParams tparams params $ \shapeparams params' -> do-    entry_rettype <- internaliseEntryReturnType rettype-    let entry' = entryPoint (zip e_paramts params') (e_rettype, entry_rettype)-        args = map (I.Var . I.paramName) $ concat params'--    entry_body <- buildBody_ $ do-      -- Special case the (rare) situation where the entry point is-      -- not a function.-      maybe_const <- lookupConst ofname-      vals <- case maybe_const of-        Just ses ->-          return ses-        Nothing ->-          fst <$> funcall "entry_result" (E.qualName ofname) args loc-      ctx <--        extractShapeContext (concat entry_rettype)-          <$> mapM (fmap I.arrayDims . subExpType) vals-      pure $ ctx ++ vals--    addFunDef $-      I.FunDef-        (Just entry')-        (internaliseAttrs attrs)-        (baseName ofname)-        (concat entry_rettype)-        (shapeparams ++ concat params')-        entry_body--entryPoint ::-  [(E.EntryType, [I.FParam])] ->-  ( E.EntryType,-    [[I.TypeBase ExtShape Uniqueness]]-  ) ->-  I.EntryPoint-entryPoint params (eret, crets) =-  ( concatMap (entryPointType . preParam) params,-    case ( isTupleRecord $ entryType eret,-           entryAscribed eret-         ) of-      (Just ts, Just (E.TETuple e_ts _)) ->-        concatMap entryPointType $-          zip (zipWith E.EntryType ts (map Just e_ts)) crets-      (Just ts, Nothing) ->-        concatMap entryPointType $-          zip (map (`E.EntryType` Nothing) ts) crets-      _ ->-        entryPointType (eret, concat crets)-  )-  where-    preParam (e_t, ps) = (e_t, staticShapes $ map I.paramDeclType ps)--    entryPointType (t, ts)-      | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t =-        [I.TypeUnsigned]-      | E.Array _ _ (E.Prim E.Unsigned {}) _ <- E.entryType t =-        [I.TypeUnsigned]-      | E.Scalar E.Prim {} <- E.entryType t =-        [I.TypeDirect]-      | E.Array _ _ E.Prim {} _ <- E.entryType t =-        [I.TypeDirect]-      | otherwise =-        [I.TypeOpaque desc $ length ts]-      where-        desc = maybe (prettyOneLine t') typeExpOpaqueName $ E.entryAscribed t-        t' = noSizes (E.entryType t) `E.setUniqueness` Nonunique-    typeExpOpaqueName (TEApply te TypeArgExpDim {} _) =-      typeExpOpaqueName te-    typeExpOpaqueName (TEArray te _ _) =-      let (d, te') = withoutDims te-       in "arr_" ++ typeExpOpaqueName te'-            ++ "_"-            ++ show (1 + d)-            ++ "d"-    typeExpOpaqueName te = prettyOneLine te--    withoutDims (TEArray te _ _) =-      let (d, te') = withoutDims te-       in (d + 1, te')-    withoutDims te = (0 :: Int, te)--internaliseBody :: String -> E.Exp -> InternaliseM Body-internaliseBody desc e =-  buildBody_ $ internaliseExp (desc <> "_res") e--bodyFromStms ::-  InternaliseM (Result, a) ->-  InternaliseM (Body, a)-bodyFromStms m = do-  ((res, a), stms) <- collectStms m-  (,a) <$> mkBodyM stms res--internaliseAppExp :: String -> E.AppExp -> InternaliseM [I.SubExp]-internaliseAppExp desc (E.Index e idxs loc) = do-  vs <- internaliseExpToVars "indexed" e-  dims <- case vs of-    [] -> return [] -- Will this happen?-    v : _ -> I.arrayDims <$> lookupType v-  (idxs', cs) <- internaliseSlice loc dims idxs-  let index v = do-        v_t <- lookupType v-        return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'-  certifying cs $ letSubExps desc =<< mapM index vs-internaliseAppExp desc (E.Range start maybe_second end loc) = do-  start' <- internaliseExp1 "range_start" start-  end' <- internaliseExp1 "range_end" $ case end of-    DownToExclusive e -> e-    ToInclusive e -> e-    UpToExclusive e -> e-  maybe_second' <--    traverse (internaliseExp1 "range_second") maybe_second--  -- Construct an error message in case the range is invalid.-  let conv = case E.typeOf start of-        E.Scalar (E.Prim (E.Unsigned _)) -> asIntZ Int64-        _ -> asIntS Int64-  start'_i64 <- conv start'-  end'_i64 <- conv end'-  maybe_second'_i64 <- traverse conv maybe_second'-  let errmsg =-        errorMsg $-          ["Range "]-            ++ [ErrorInt64 start'_i64]-            ++ ( case maybe_second'_i64 of-                   Nothing -> []-                   Just second_i64 -> ["..", ErrorInt64 second_i64]-               )-            ++ ( case end of-                   DownToExclusive {} -> ["..>"]-                   ToInclusive {} -> ["..."]-                   UpToExclusive {} -> ["..<"]-               )-            ++ [ErrorInt64 end'_i64, " is invalid."]--  (it, le_op, lt_op) <--    case E.typeOf start of-      E.Scalar (E.Prim (E.Signed it)) -> return (it, CmpSle it, CmpSlt it)-      E.Scalar (E.Prim (E.Unsigned it)) -> return (it, CmpUle it, CmpUlt it)-      start_t -> error $ "Start value in range has type " ++ pretty start_t--  let one = intConst it 1-      negone = intConst it (-1)-      default_step = case end of-        DownToExclusive {} -> negone-        ToInclusive {} -> one-        UpToExclusive {} -> one--  (step, step_zero) <- case maybe_second' of-    Just second' -> do-      subtracted_step <--        letSubExp "subtracted_step" $-          I.BasicOp $ I.BinOp (I.Sub it I.OverflowWrap) second' start'-      step_zero <- letSubExp "step_zero" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) start' second'-      return (subtracted_step, step_zero)-    Nothing ->-      return (default_step, constant False)--  step_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum it) step-  step_sign_i64 <- asIntS Int64 step_sign--  bounds_invalid_downwards <--    letSubExp "bounds_invalid_downwards" $-      I.BasicOp $ I.CmpOp le_op start' end'-  bounds_invalid_upwards <--    letSubExp "bounds_invalid_upwards" $-      I.BasicOp $ I.CmpOp lt_op end' start'--  (distance, step_wrong_dir, bounds_invalid) <- case end of-    DownToExclusive {} -> do-      step_wrong_dir <--        letSubExp "step_wrong_dir" $-          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign one-      distance <--        letSubExp "distance" $-          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end'-      distance_i64 <- asIntS Int64 distance-      return (distance_i64, step_wrong_dir, bounds_invalid_downwards)-    UpToExclusive {} -> do-      step_wrong_dir <--        letSubExp "step_wrong_dir" $-          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone-      distance <- letSubExp "distance" $ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start'-      distance_i64 <- asIntS Int64 distance-      return (distance_i64, step_wrong_dir, bounds_invalid_upwards)-    ToInclusive {} -> do-      downwards <--        letSubExp "downwards" $-          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone-      distance_downwards_exclusive <--        letSubExp "distance_downwards_exclusive" $-          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end'-      distance_upwards_exclusive <--        letSubExp "distance_upwards_exclusive" $-          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start'--      bounds_invalid <--        letSubExp "bounds_invalid" $-          I.If-            downwards-            (resultBody [bounds_invalid_downwards])-            (resultBody [bounds_invalid_upwards])-            $ ifCommon [I.Prim I.Bool]-      distance_exclusive <--        letSubExp "distance_exclusive" $-          I.If-            downwards-            (resultBody [distance_downwards_exclusive])-            (resultBody [distance_upwards_exclusive])-            $ ifCommon [I.Prim $ IntType it]-      distance_exclusive_i64 <- asIntS Int64 distance_exclusive-      distance <--        letSubExp "distance" $-          I.BasicOp $-            I.BinOp-              (Add Int64 I.OverflowWrap)-              distance_exclusive_i64-              (intConst Int64 1)-      return (distance, constant False, bounds_invalid)--  step_invalid <--    letSubExp "step_invalid" $-      I.BasicOp $ I.BinOp I.LogOr step_wrong_dir step_zero--  invalid <--    letSubExp "range_invalid" $-      I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid-  valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid-  cs <- assert "range_valid_c" valid errmsg loc--  step_i64 <- asIntS Int64 step-  pos_step <--    letSubExp "pos_step" $-      I.BasicOp $ I.BinOp (Mul Int64 I.OverflowWrap) step_i64 step_sign_i64--  num_elems <--    certifying cs $-      letSubExp "num_elems" $-        I.BasicOp $ I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step--  se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)-  return [se]-internaliseAppExp desc (E.Coerce e (TypeDecl dt (Info et)) loc) = do-  ses <- internaliseExp desc e-  ts <- internaliseReturnType et =<< mapM subExpType ses-  dt' <- typeExpForError dt-  forM (zip ses ts) $ \(e', t') -> do-    dims <- arrayDims <$> subExpType e'-    let parts =-          ["Value of (core language) shape ("]-            ++ intersperse ", " (map ErrorInt64 dims)-            ++ [") cannot match shape of type `"]-            ++ dt'-            ++ ["`."]-    ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e'-internaliseAppExp desc e@E.Apply {} = do-  (qfname, args) <- findFuncall e--  -- Argument evaluation is outermost-in so that any existential sizes-  -- created by function applications can be brought into scope.-  let fname = nameFromString $ pretty $ baseName $ qualLeaf qfname-      loc = srclocOf e-      arg_desc = nameToString fname ++ "_arg"--  -- Some functions are magical (overloaded) and we handle that here.-  case () of-    -- Overloaded functions never take array arguments (except-    -- equality, but those cannot be existential), so we can safely-    -- ignore the existential dimensions.-    ()-      | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->-        internalise desc-      | baseTag (qualLeaf qfname) <= maxIntrinsicTag,-        Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do-        let tag ses = [(se, I.Observe) | se <- ses]-        args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)-        let args'' = concatMap tag args'-        letTupExp' desc $-          I.Apply-            fname-            args''-            [I.Prim rettype]-            (Safe, loc, [])-      | otherwise -> do-        args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)-        fst <$> funcall desc qfname args' loc-internaliseAppExp desc (E.LetPat sizes pat e body _) =-  internalisePat desc sizes pat e body (internaliseExp desc)-internaliseAppExp _ (E.LetFun ofname _ _ _) =-  error $ "Unexpected LetFun " ++ pretty ofname-internaliseAppExp desc (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do-  ses <- internaliseExp "loop_init" mergeexp-  ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <--    collectStms $ handleForm ses form--  addStms initstms-  mergeinit_ts' <- mapM subExpType mergeinit'--  ctxinit <- argShapes (map I.paramName shapepat) mergepat' mergeinit_ts'--  let ctxmerge = zip shapepat ctxinit-      valmerge = zip mergepat' mergeinit'-      dropCond = case form of-        E.While {} -> drop 1-        _ -> id--  -- Ensure that the result of the loop matches the shapes of the-  -- merge parameters.  XXX: Ideally they should already match (by-  -- the source language type rules), but some of our-  -- transformations (esp. defunctionalisation) strips out some size-  -- information.  For a type-correct source program, these reshapes-  -- should simplify away.-  let merge = ctxmerge ++ valmerge-      merge_ts = map (I.paramType . fst) merge-  loopbody'' <--    localScope (scopeOfFParams $ map fst merge) . inScopeOf form' . buildBody_ $-      ensureArgShapes-        "shape of loop result does not match shapes in loop parameter"-        loc-        (map (I.paramName . fst) ctxmerge)-        merge_ts-        =<< bodyBind loopbody'--  attrs <- asks envAttrs-  map I.Var . dropCond-    <$> attributing-      attrs-      (letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody''))-  where-    sparams' = map (`TypeParamDim` mempty) sparams--    forLoop mergepat' shapepat mergeinit form' =-      bodyFromStms $-        inScopeOf form' $ do-          ses <- internaliseExp "loopres" loopbody-          sets <- mapM subExpType ses-          shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets-          return-            ( shapeargs ++ ses,-              ( form',-                shapepat,-                mergepat',-                mergeinit-              )-            )--    handleForm mergeinit (E.ForIn x arr) = do-      arr' <- internaliseExpToVars "for_in_arr" arr-      arr_ts <- mapM lookupType arr'-      let w = arraysSize 0 arr_ts--      i <- newVName "i"--      ts <- mapM subExpType mergeinit-      bindingLoopParams sparams' mergepat ts $-        \shapepat mergepat' ->-          bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do-            let loopvars = zip x_params arr'-            forLoop mergepat' shapepat mergeinit $-              I.ForLoop i Int64 w loopvars-    handleForm mergeinit (E.For i num_iterations) = do-      num_iterations' <- internaliseExp1 "upper_bound" num_iterations-      num_iterations_t <- I.subExpType num_iterations'-      it <- case num_iterations_t of-        I.Prim (IntType it) -> return it-        _ -> error "internaliseExp DoLoop: invalid type"--      ts <- mapM subExpType mergeinit-      bindingLoopParams sparams' mergepat ts $-        \shapepat mergepat' ->-          forLoop mergepat' shapepat mergeinit $-            I.ForLoop (E.identName i) it num_iterations' []-    handleForm mergeinit (E.While cond) = do-      ts <- mapM subExpType mergeinit-      bindingLoopParams sparams' mergepat ts $ \shapepat mergepat' -> do-        mergeinit_ts <- mapM subExpType mergeinit-        -- We need to insert 'cond' twice - once for the initial-        -- condition (do we enter the loop at all?), and once with the-        -- result values of the loop (do we continue into the next-        -- iteration?).  This is safe, as the type rules for the-        -- external language guarantees that 'cond' does not consume-        -- anything.-        shapeinit <- argShapes (map I.paramName shapepat) mergepat' mergeinit_ts--        (loop_initial_cond, init_loop_cond_bnds) <- collectStms $ do-          forM_ (zip shapepat shapeinit) $ \(p, se) ->-            letBindNames [paramName p] $ BasicOp $ SubExp se-          forM_ (zip mergepat' mergeinit) $ \(p, se) ->-            unless (se == I.Var (paramName p)) $-              letBindNames [paramName p] $-                BasicOp $-                  case se of-                    I.Var v-                      | not $ primType $ paramType p ->-                        Reshape (map DimCoercion $ arrayDims $ paramType p) v-                    _ -> SubExp se-          internaliseExp1 "loop_cond" cond--        addStms init_loop_cond_bnds--        bodyFromStms $ do-          ses <- internaliseExp "loopres" loopbody-          sets <- mapM subExpType ses-          loop_while <- newParam "loop_while" $ I.Prim I.Bool-          shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets--          -- Careful not to clobber anything.-          loop_end_cond_body <- renameBody <=< buildBody_ $ do-            forM_ (zip shapepat shapeargs) $ \(p, se) ->-              unless (se == I.Var (paramName p)) $-                letBindNames [paramName p] $ BasicOp $ SubExp se-            forM_ (zip mergepat' ses) $ \(p, se) ->-              unless (se == I.Var (paramName p)) $-                letBindNames [paramName p] $-                  BasicOp $-                    case se of-                      I.Var v-                        | not $ primType $ paramType p ->-                          Reshape (map DimCoercion $ arrayDims $ paramType p) v-                      _ -> SubExp se-            internaliseExp "loop_cond" cond-          loop_end_cond <- bodyBind loop_end_cond_body--          return-            ( shapeargs ++ loop_end_cond ++ ses,-              ( I.WhileLoop $ I.paramName loop_while,-                shapepat,-                loop_while : mergepat',-                loop_initial_cond : mergeinit-              )-            )-internaliseAppExp desc (E.LetWith name src idxs ve body loc) = do-  let pat = E.Id (E.identName name) (E.identType name) loc-      src_t = E.fromStruct <$> E.identType src-      e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc-  internaliseExp desc $-    E.AppExp-      (E.LetPat [] pat e body loc)-      (Info (AppRes (E.typeOf body) mempty))-internaliseAppExp desc (E.Match e cs _) = do-  ses <- internaliseExp (desc ++ "_scrutinee") e-  case NE.uncons cs of-    (CasePat pCase eCase _, Nothing) -> do-      (_, pertinent) <- generateCond pCase ses-      internalisePat' [] pCase pertinent eCase (internaliseExp desc)-    (c, Just cs') -> do-      let CasePat pLast eLast _ = NE.last cs'-      bFalse <- do-        (_, pertinent) <- generateCond pLast ses-        eLast' <- internalisePat' [] pLast pertinent eLast (internaliseBody desc)-        foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $-          reverse $ NE.init cs'-      letTupExp' desc =<< generateCaseIf ses c bFalse-internaliseAppExp desc (E.If ce te fe _) =-  letTupExp' desc-    =<< eIf-      (BasicOp . SubExp <$> internaliseExp1 "cond" ce)-      (internaliseBody (desc <> "_t") te)-      (internaliseBody (desc <> "_f") fe)-internaliseAppExp _ e@E.BinOp {} =-  error $ "internaliseAppExp: Unexpected BinOp " ++ pretty e--internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp]-internaliseExp desc (E.Parens e _) =-  internaliseExp desc e-internaliseExp desc (E.QualParens _ e _) =-  internaliseExp desc e-internaliseExp desc (E.StringLit vs _) =-  fmap pure $-    letSubExp desc $-      I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8-internaliseExp _ (E.Var (E.QualName _ name) _ _) = do-  subst <- lookupSubst name-  case subst of-    Just substs -> return substs-    Nothing -> pure [I.Var name]-internaliseExp desc (E.AppExp e (Info appres)) = do-  ses <- internaliseAppExp desc e-  bindExtSizes appres ses-  pure ses---- XXX: we map empty records and tuples to units, because otherwise--- arrays of unit will lose their sizes.-internaliseExp _ (E.TupLit [] _) =-  return [constant UnitValue]-internaliseExp _ (E.RecordLit [] _) =-  return [constant UnitValue]-internaliseExp desc (E.TupLit es _) = concat <$> mapM (internaliseExp desc) es-internaliseExp desc (E.RecordLit orig_fields _) =-  concatMap snd . sortFields . M.unions <$> mapM internaliseField orig_fields-  where-    internaliseField (E.RecordFieldExplicit name e _) =-      M.singleton name <$> internaliseExp desc e-    internaliseField (E.RecordFieldImplicit name t loc) =-      internaliseField $-        E.RecordFieldExplicit-          (baseName name)-          (E.Var (E.qualName name) t loc)-          loc-internaliseExp desc (E.ArrayLit es (Info arr_t) loc)-  -- If this is a multidimensional array literal of primitives, we-  -- treat it specially by flattening it out followed by a reshape.-  -- This cuts down on the amount of statements that are produced, and-  -- thus allows us to efficiently handle huge array literals - a-  -- corner case, but an important one.-  | Just ((eshape, e') : es') <- mapM isArrayLiteral es,-    not $ null eshape,-    all ((eshape ==) . fst) es',-    Just basetype <- E.peelArray (length eshape) arr_t = do-    let flat_lit = E.ArrayLit (e' ++ concatMap snd es') (Info basetype) loc-        new_shape = length es : eshape-    flat_arrs <- internaliseExpToVars "flat_literal" flat_lit-    forM flat_arrs $ \flat_arr -> do-      flat_arr_t <- lookupType flat_arr-      let new_shape' =-            reshapeOuter-              (map (DimNew . intConst Int64 . toInteger) new_shape)-              1-              $ I.arrayShape flat_arr_t-      letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr-  | otherwise = do-    es' <- mapM (internaliseExp "arr_elem") es-    arr_t_ext <- internaliseType $ E.toStruct arr_t--    rowtypes <--      case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of-        Just ts -> pure ts-        Nothing ->-          -- XXX: the monomorphiser may create single-element array-          -- literals with an unknown row type.  In those cases we-          -- need to look at the types of the actual elements.-          -- Fixing this in the monomorphiser is a lot more tricky-          -- than just working around it here.-          case es' of-            [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t-            e' : _ -> mapM subExpType e'--    let arraylit ks rt = do-          ks' <--            mapM-              ( ensureShape-                  "shape of element differs from shape of first element"-                  loc-                  rt-                  "elem_reshaped"-              )-              ks-          return $ I.BasicOp $ I.ArrayLit ks' rt--    letSubExps desc-      =<< if null es'-        then mapM (arraylit []) rowtypes-        else zipWithM arraylit (transpose es') rowtypes-  where-    isArrayLiteral :: E.Exp -> Maybe ([Int], [E.Exp])-    isArrayLiteral (E.ArrayLit inner_es _ _) = do-      (eshape, e) : inner_es' <- mapM isArrayLiteral inner_es-      guard $ all ((eshape ==) . fst) inner_es'-      return (length inner_es : eshape, e ++ concatMap snd inner_es')-    isArrayLiteral e =-      Just ([], [e])-internaliseExp desc (E.Ascript e _ _) =-  internaliseExp desc e-internaliseExp desc (E.Negate e _) = do-  e' <- internaliseExp1 "negate_arg" e-  et <- subExpType e'-  case et of-    I.Prim (I.IntType t) ->-      letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e'-    I.Prim (I.FloatType t) ->-      letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'-    _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"-internaliseExp desc (E.Update src slice ve loc) = do-  ves <- internaliseExp "lw_val" ve-  srcs <- internaliseExpToVars "src" src-  dims <- case srcs of-    [] -> return [] -- Will this happen?-    v : _ -> I.arrayDims <$> lookupType v-  (idxs', cs) <- internaliseSlice loc dims slice--  let comb sname ve' = do-        sname_t <- lookupType sname-        let full_slice = fullSlice sname_t idxs'-            rowtype = sname_t `setArrayDims` sliceDims full_slice-        ve'' <--          ensureShape-            "shape of value does not match shape of source array"-            loc-            rowtype-            "lw_val_correct_shape"-            ve'-        letInPlace desc sname full_slice $ BasicOp $ SubExp ve''-  certifying cs $ map I.Var <$> zipWithM comb srcs ves-internaliseExp desc (E.RecordUpdate src fields ve _ _) = do-  src' <- internaliseExp desc src-  ve' <- internaliseExp desc ve-  replace (E.typeOf src `setAliases` ()) fields ve' src'-  where-    replace (E.Scalar (E.Record m)) (f : fs) ve' src'-      | Just t <- M.lookup f m = do-        i <--          fmap sum $-            mapM (internalisedTypeSize . snd) $-              takeWhile ((/= f) . fst) $ sortFields m-        k <- internalisedTypeSize t-        let (bef, to_update, aft) = splitAt3 i k src'-        src'' <- replace t fs ve' to_update-        return $ bef ++ src'' ++ aft-    replace _ _ ve' _ = return ve'-internaliseExp desc (E.Attr attr e _) =-  local f $ internaliseExp desc e-  where-    attrs = oneAttr $ internaliseAttr attr-    f env-      | "unsafe" `inAttrs` attrs,-        not $ envSafe env =-        env {envDoBoundsChecks = False}-      | otherwise =-        env {envAttrs = envAttrs env <> attrs}-internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do-  e1' <- internaliseExp1 "assert_cond" e1-  c <- assert "assert_c" e1' (errorMsg [ErrorString $ "Assertion is false: " <> check]) loc-  -- Make sure there are some bindings to certify.-  certifying c $ mapM rebind =<< internaliseExp desc e2-  where-    rebind v = do-      v' <- newVName "assert_res"-      letBindNames [v'] $ I.BasicOp $ I.SubExp v-      return $ I.Var v'-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 Int64 0-  ts' <- instantiateShapes noExt $ map fromDecl ts--  case M.lookup c constr_map of-    Just (i, js) ->-      (intConst Int8 (toInteger i) :) <$> clauses 0 ts' (zip js es')-    Nothing ->-      error "internaliseExp Constr: missing constructor"-  where-    clauses j (t : ts) js_to_es-      | Just e <- j `lookup` js_to_es =-        (e :) <$> clauses (j + 1) ts js_to_es-      | otherwise = do-        blank <- letSubExp "zero" =<< eBlank t-        (blank :) <$> clauses (j + 1) ts js_to_es-    clauses _ [] _ =-      return []-internaliseExp _ (E.Constr _ _ (Info t) loc) =-  error $ "internaliseExp: constructor with type " ++ pretty t ++ " at " ++ locStr loc--- The "interesting" cases are over, now it's mostly boilerplate.--internaliseExp _ (E.Literal v _) =-  return [I.Constant $ internalisePrimValue v]-internaliseExp _ (E.IntLit v (Info t) _) =-  case t of-    E.Scalar (E.Prim (E.Signed it)) ->-      return [I.Constant $ I.IntValue $ intValue it v]-    E.Scalar (E.Prim (E.Unsigned it)) ->-      return [I.Constant $ I.IntValue $ intValue it v]-    E.Scalar (E.Prim (E.FloatType ft)) ->-      return [I.Constant $ I.FloatValue $ floatValue ft v]-    _ -> error $ "internaliseExp: nonsensical type for integer literal: " ++ pretty t-internaliseExp _ (E.FloatLit v (Info t) _) =-  case t of-    E.Scalar (E.Prim (E.FloatType ft)) ->-      return [I.Constant $ I.FloatValue $ floatValue ft v]-    _ -> error $ "internaliseExp: nonsensical type for float literal: " ++ pretty t--- Builtin operators are handled specially because they are--- overloaded.-internaliseExp desc (E.Project k e (Info rt) _) = do-  n <- internalisedTypeSize $ rt `setAliases` ()-  i' <- fmap sum $-    mapM internalisedTypeSize $-      case E.typeOf e `setAliases` () of-        E.Scalar (Record fs) ->-          map snd $ takeWhile ((/= k) . fst) $ sortFields fs-        t -> [t]-  take n . drop i' <$> internaliseExp desc e-internaliseExp _ e@E.Lambda {} =-  error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e)-internaliseExp _ e@E.OpSection {} =-  error $ "internaliseExp: Unexpected operator section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.OpSectionLeft {} =-  error $ "internaliseExp: Unexpected left operator section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.OpSectionRight {} =-  error $ "internaliseExp: Unexpected right operator section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.ProjectSection {} =-  error $ "internaliseExp: Unexpected projection section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.IndexSection {} =-  error $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e)--internaliseArg :: String -> (E.Exp, Maybe VName) -> InternaliseM [SubExp]-internaliseArg desc (arg, argdim) = do-  arg' <- internaliseExp desc arg-  case (arg', argdim) of-    ([se], Just d) -> letBindNames [d] $ BasicOp $ SubExp se-    _ -> return ()-  return arg'--subExpPrimType :: I.SubExp -> InternaliseM I.PrimType-subExpPrimType = fmap I.elemType . subExpType--generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp])-generateCond orig_p orig_ses = do-  (cmps, pertinent, _) <- compares orig_p orig_ses-  cmp <- letSubExp "matches" =<< eAll cmps-  return (cmp, pertinent)-  where-    -- Literals are always primitive values.-    compares (E.PatternLit l t _) (se : ses) = do-      e' <- case l of-        PatLitPrim v -> pure $ constant $ internalisePrimValue v-        PatLitInt x -> internaliseExp1 "constant" $ E.IntLit x t mempty-        PatLitFloat x -> internaliseExp1 "constant" $ E.FloatLit x t mempty-      t' <- subExpPrimType se-      cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se-      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-      case M.lookup c m of-        Just (i, payload_is) -> do-          let i' = intConst Int8 $ toInteger i-          let (payload_ses, ses') = splitAt (length payload_ts) ses-          cmp <- letSubExp "match_constr" $ I.BasicOp $ I.CmpOp (I.CmpEq int8) i' se-          (cmps, pertinent, _) <- comparesMany pats $ map (payload_ses !!) payload_is-          return (cmp : cmps, pertinent, ses')-        Nothing ->-          error "generateCond: missing constructor"-    compares (E.PatternConstr _ (Info t) _ _) _ =-      error $ "generateCond: PatternConstr has nonsensical type: " ++ pretty t-    compares (E.Id _ t loc) ses =-      compares (E.Wildcard t loc) ses-    compares (E.Wildcard (Info t) _) ses = do-      n <- internalisedTypeSize $ E.toStruct t-      let (id_ses, rest_ses) = splitAt n ses-      return ([], id_ses, rest_ses)-    compares (E.PatternParens pat _) ses =-      compares pat ses-    -- XXX: treat empty tuples and records as bool.-    compares (E.TuplePattern [] loc) ses =-      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses-    compares (E.RecordPattern [] loc) ses =-      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses-    compares (E.TuplePattern pats _) ses =-      comparesMany pats ses-    compares (E.RecordPattern fs _) ses =-      comparesMany (map snd $ E.sortFields $ M.fromList fs) ses-    compares (E.PatternAscription pat _ _) ses =-      compares pat ses-    compares pat [] =-      error $ "generateCond: No values left for pattern " ++ pretty pat--    comparesMany [] ses = return ([], [], ses)-    comparesMany (pat : pats) ses = do-      (cmps1, pertinent1, ses') <- compares pat ses-      (cmps2, pertinent2, ses'') <- comparesMany pats ses'-      return-        ( cmps1 <> cmps2,-          pertinent1 <> pertinent2,-          ses''-        )--generateCaseIf :: [I.SubExp] -> Case -> I.Body -> InternaliseM I.Exp-generateCaseIf ses (CasePat p eCase _) bFail = do-  (cond, pertinent) <- generateCond p ses-  eCase' <- internalisePat' [] p pertinent eCase (internaliseBody "case")-  eIf (eSubExp cond) (return eCase') (return bFail)--internalisePat ::-  String ->-  [E.SizeBinder VName] ->-  E.Pattern ->-  E.Exp ->-  E.Exp ->-  (E.Exp -> InternaliseM a) ->-  InternaliseM a-internalisePat desc sizes p e body m = do-  ses <- internaliseExp desc' e-  internalisePat' sizes p ses body m-  where-    desc' = case S.toList $ E.patternIdents p of-      [v] -> baseString $ E.identName v-      _ -> desc--internalisePat' ::-  [E.SizeBinder VName] ->-  E.Pattern ->-  [I.SubExp] ->-  E.Exp ->-  (E.Exp -> InternaliseM a) ->-  InternaliseM a-internalisePat' sizes p ses body m = do-  ses_ts <- mapM subExpType ses-  stmPattern p ses_ts $ \pat_names -> do-    bindExtSizes (AppRes (E.patternType p) (map E.sizeName sizes)) ses-    forM_ (zip pat_names ses) $ \(v, se) ->-      letBindNames [v] $ I.BasicOp $ I.SubExp se-    m body--internaliseSlice ::-  SrcLoc ->-  [SubExp] ->-  [E.DimIndex] ->-  InternaliseM ([I.DimIndex SubExp], Certificates)-internaliseSlice loc dims idxs = do-  (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs-  ok <- letSubExp "index_ok" =<< eAll oks-  let msg =-        errorMsg $-          ["Index ["] ++ intercalate [", "] parts-            ++ ["] out of bounds for array of shape ["]-            ++ intersperse "][" (map ErrorInt64 $ take (length idxs) dims)-            ++ ["]."]-  c <- assert "index_certs" ok msg loc-  return (idxs', c)--internaliseDimIndex ::-  SubExp ->-  E.DimIndex ->-  InternaliseM (I.DimIndex SubExp, SubExp, [ErrorMsgPart SubExp])-internaliseDimIndex w (E.DimFix i) = do-  (i', _) <- internaliseDimExp "i" i-  let lowerBound =-        I.BasicOp $-          I.CmpOp (I.CmpSle I.Int64) (I.constant (0 :: I.Int64)) i'-      upperBound =-        I.BasicOp $-          I.CmpOp (I.CmpSlt I.Int64) i' w-  ok <- letSubExp "bounds_check" =<< eBinOp I.LogAnd (pure lowerBound) (pure upperBound)-  return (I.DimFix i', ok, [ErrorInt64 i'])---- Special-case an important common case that otherwise leads to horrible code.-internaliseDimIndex-  w-  ( E.DimSlice-      Nothing-      Nothing-      (Just (E.Negate (E.IntLit 1 _ _) _))-    ) = do-    w_minus_1 <--      letSubExp "w_minus_1" $-        BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one-    return-      ( I.DimSlice w_minus_1 w $ intConst Int64 (-1),-        constant True,-        mempty-      )-    where-      one = constant (1 :: Int64)-internaliseDimIndex w (E.DimSlice i j s) = do-  s' <- maybe (return one) (fmap fst . internaliseDimExp "s") s-  s_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum Int64) s'-  backwards <- letSubExp "backwards" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) s_sign negone-  w_minus_1 <- letSubExp "w_minus_1" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one-  let i_def =-        letSubExp "i_def" $-          I.If-            backwards-            (resultBody [w_minus_1])-            (resultBody [zero])-            $ ifCommon [I.Prim int64]-      j_def =-        letSubExp "j_def" $-          I.If-            backwards-            (resultBody [negone])-            (resultBody [w])-            $ ifCommon [I.Prim int64]-  i' <- maybe i_def (fmap fst . internaliseDimExp "i") i-  j' <- maybe j_def (fmap fst . internaliseDimExp "j") j-  j_m_i <- letSubExp "j_m_i" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) j' i'-  -- Something like a division-rounding-up, but accomodating negative-  -- operands.-  let divRounding x y =-        eBinOp-          (SQuot Int64 Unsafe)-          ( eBinOp-              (Add Int64 I.OverflowWrap)-              x-              (eBinOp (Sub Int64 I.OverflowWrap) y (eSignum $ toExp s'))-          )-          y-  n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s')--  -- Bounds checks depend on whether we are slicing forwards or-  -- backwards.  If forwards, we must check '0 <= i && i <= j'.  If-  -- backwards, '-1 <= j && j <= i'.  In both cases, we check '0 <=-  -- i+n*s && i+(n-1)*s < w'.  We only check if the slice is nonempty.-  empty_slice <- letSubExp "empty_slice" $ I.BasicOp $ I.CmpOp (CmpEq int64) n zero--  m <- letSubExp "m" $ I.BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) n one-  m_t_s <- letSubExp "m_t_s" $ I.BasicOp $ I.BinOp (Mul Int64 I.OverflowWrap) m s'-  i_p_m_t_s <- letSubExp "i_p_m_t_s" $ I.BasicOp $ I.BinOp (Add Int64 I.OverflowWrap) i' m_t_s-  zero_leq_i_p_m_t_s <--    letSubExp "zero_leq_i_p_m_t_s" $-      I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i_p_m_t_s-  i_p_m_t_s_leq_w <--    letSubExp "i_p_m_t_s_leq_w" $-      I.BasicOp $ I.CmpOp (I.CmpSle Int64) i_p_m_t_s w-  i_p_m_t_s_lth_w <--    letSubExp "i_p_m_t_s_leq_w" $-      I.BasicOp $ I.CmpOp (I.CmpSlt Int64) i_p_m_t_s w--  zero_lte_i <- letSubExp "zero_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i'-  i_lte_j <- letSubExp "i_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) i' j'-  forwards_ok <--    letSubExp "forwards_ok"-      =<< eAll [zero_lte_i, zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w]--  negone_lte_j <- letSubExp "negone_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) negone j'-  j_lte_i <- letSubExp "j_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) j' i'-  backwards_ok <--    letSubExp "backwards_ok"-      =<< eAll-        [negone_lte_j, negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w]--  slice_ok <--    letSubExp "slice_ok" $-      I.If-        backwards-        (resultBody [backwards_ok])-        (resultBody [forwards_ok])-        $ ifCommon [I.Prim I.Bool]-  ok_or_empty <--    letSubExp "ok_or_empty" $-      I.BasicOp $ I.BinOp I.LogOr empty_slice slice_ok--  let parts = case (i, j, s) of-        (_, _, Just {}) ->-          [ maybe "" (const $ ErrorInt64 i') i,-            ":",-            maybe "" (const $ ErrorInt64 j') j,-            ":",-            ErrorInt64 s'-          ]-        (_, Just {}, _) ->-          [ maybe "" (const $ ErrorInt64 i') i,-            ":",-            ErrorInt64 j'-          ]-            ++ maybe mempty (const [":", ErrorInt64 s']) s-        (_, Nothing, Nothing) ->-          [ErrorInt64 i', ":"]-  return (I.DimSlice i' n s', ok_or_empty, parts)-  where-    zero = constant (0 :: Int64)-    negone = constant (-1 :: Int64)-    one = constant (1 :: Int64)--internaliseScanOrReduce ::-  String ->-  String ->-  (SubExp -> I.Lambda -> [SubExp] -> [VName] -> InternaliseM (SOAC SOACS)) ->-  (E.Exp, E.Exp, E.Exp, SrcLoc) ->-  InternaliseM [SubExp]-internaliseScanOrReduce desc what f (lam, ne, arr, loc) = do-  arrs <- internaliseExpToVars (what ++ "_arr") arr-  nes <- internaliseExp (what ++ "_ne") ne-  nes' <- forM (zip nes arrs) $ \(ne', arr') -> do-    rowtype <- I.stripArray 1 <$> lookupType arr'-    ensureShape-      "Row shape of input array does not match shape of neutral element"-      loc-      rowtype-      (what ++ "_ne_right_shape")-      ne'-  nests <- mapM I.subExpType nes'-  arrts <- mapM lookupType arrs-  lam' <- internaliseFoldLambda internaliseLambda lam nests arrts-  w <- arraysSize 0 <$> mapM lookupType arrs-  letTupExp' desc . I.Op =<< f w lam' nes' arrs--internaliseHist ::-  String ->-  E.Exp ->-  E.Exp ->-  E.Exp ->-  E.Exp ->-  E.Exp ->-  E.Exp ->-  SrcLoc ->-  InternaliseM [SubExp]-internaliseHist desc rf hist op ne buckets img loc = do-  rf' <- internaliseExp1 "hist_rf" rf-  ne' <- internaliseExp "hist_ne" ne-  hist' <- internaliseExpToVars "hist_hist" hist-  buckets' <--    letExp "hist_buckets" . BasicOp . SubExp-      =<< internaliseExp1 "hist_buckets" buckets-  img' <- internaliseExpToVars "hist_img" img--  -- reshape neutral element to have same size as the destination array-  ne_shp <- forM (zip ne' hist') $ \(n, h) -> do-    rowtype <- I.stripArray 1 <$> lookupType h-    ensureShape-      "Row shape of destination array does not match shape of neutral element"-      loc-      rowtype-      "hist_ne_right_shape"-      n-  ne_ts <- mapM I.subExpType ne_shp-  his_ts <- mapM lookupType hist'-  op' <- internaliseFoldLambda internaliseLambda op ne_ts his_ts--  -- reshape return type of bucket function to have same size as neutral element-  -- (modulo the index)-  bucket_param <- newParam "bucket_p" $ I.Prim int64-  img_params <- mapM (newParam "img_p" . rowType) =<< mapM lookupType img'-  let params = bucket_param : img_params-      rettype = I.Prim int64 : ne_ts-      body = mkBody mempty $ map (I.Var . paramName) params-  lam' <--    mkLambda params $-      ensureResultShape-        "Row shape of value array does not match row shape of hist target"-        (srclocOf img)-        rettype-        =<< bodyBind body--  -- get sizes of histogram and image arrays-  w_hist <- arraysSize 0 <$> mapM lookupType hist'-  w_img <- arraysSize 0 <$> mapM lookupType img'--  -- Generate an assertion and reshapes to ensure that buckets' and-  -- img' are the same size.-  b_shape <- I.arrayShape <$> lookupType buckets'-  let b_w = shapeSize 0 b_shape-  cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int64) b_w w_img-  c <--    assert-      "bucket_cert"-      cmp-      "length of index and value array does not match"-      loc-  buckets'' <--    certifying c $-      letExp (baseString buckets') $-        I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets'--  letTupExp' desc . I.Op $-    I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] lam' $ buckets'' : img'--internaliseStreamMap ::-  String ->-  StreamOrd ->-  E.Exp ->-  E.Exp ->-  InternaliseM [SubExp]-internaliseStreamMap desc o lam arr = do-  arrs <- internaliseExpToVars "stream_input" arr-  lam' <- internaliseStreamMapLambda internaliseLambda lam $ map I.Var arrs-  w <- arraysSize 0 <$> mapM lookupType arrs-  let form = I.Parallel o Commutative (I.Lambda [] (mkBody mempty []) [])-  letTupExp' desc $ I.Op $ I.Stream w arrs form [] lam'--internaliseStreamRed ::-  String ->-  StreamOrd ->-  Commutativity ->-  E.Exp ->-  E.Exp ->-  E.Exp ->-  InternaliseM [SubExp]-internaliseStreamRed desc o comm lam0 lam arr = do-  arrs <- internaliseExpToVars "stream_input" arr-  rowts <- mapM (fmap I.rowType . lookupType) arrs-  (lam_params, lam_body) <--    internaliseStreamLambda internaliseLambda lam rowts-  let (chunk_param, _, lam_val_params) =-        partitionChunkedFoldParameters 0 lam_params--  -- Synthesize neutral elements by applying the fold function-  -- to an empty chunk.-  letBindNames [I.paramName chunk_param] $-    I.BasicOp $ I.SubExp $ constant (0 :: Int64)-  forM_ lam_val_params $ \p ->-    letBindNames [I.paramName p] $-      I.BasicOp $-        I.Scratch (I.elemType $ I.paramType p) $-          I.arrayDims $ I.paramType p-  nes <- bodyBind =<< renameBody lam_body--  nes_ts <- mapM I.subExpType nes-  outsz <- arraysSize 0 <$> mapM lookupType arrs-  let acc_arr_tps = [I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- nes_ts]-  lam0' <- internaliseFoldLambda internaliseLambda lam0 nes_ts acc_arr_tps--  let lam0_acc_params = take (length nes) $ I.lambdaParams lam0'-  lam_acc_params <- forM lam0_acc_params $ \p -> do-    name <- newVName $ baseString $ I.paramName p-    return p {I.paramName = name}--  -- Make sure the chunk size parameter comes first.-  let lam_params' = chunk_param : lam_acc_params ++ lam_val_params--  lam' <- mkLambda lam_params' $ do-    lam_res <- bodyBind lam_body-    lam_res' <--      ensureArgShapes-        "shape of chunk function result does not match shape of initial value"-        (srclocOf lam)-        []-        (map I.typeOf $ I.lambdaParams lam0')-        lam_res-    ensureResultShape-      "shape of result does not match shape of initial value"-      (srclocOf lam0)-      nes_ts-      =<< ( eLambda lam0' . map eSubExp $-              map (I.Var . paramName) lam_acc_params ++ lam_res'-          )--  let form = I.Parallel o comm lam0'-  w <- arraysSize 0 <$> mapM lookupType arrs-  letTupExp' desc $ I.Op $ I.Stream w arrs form nes lam'--internaliseStreamAcc ::-  String ->-  E.Exp ->-  Maybe (E.Exp, E.Exp) ->-  E.Exp ->-  E.Exp ->-  InternaliseM [SubExp]-internaliseStreamAcc desc dest op lam bs = do-  dest' <- internaliseExpToVars "scatter_dest" dest-  bs' <- internaliseExpToVars "scatter_input" bs--  acc_cert_v <- newVName "acc_cert"-  dest_ts <- mapM lookupType dest'-  let dest_w = arraysSize 0 dest_ts-      acc_t = Acc acc_cert_v (Shape [dest_w]) (map rowType dest_ts) NoUniqueness-  acc_p <- newParam "acc_p" acc_t-  withacc_lam <- mkLambda [Param acc_cert_v (I.Prim I.Unit), acc_p] $ do-    lam' <--      internaliseMapLambda internaliseLambda lam $-        map I.Var $ paramName acc_p : bs'-    w <- arraysSize 0 <$> mapM lookupType bs'-    letTupExp' "acc_res" $ I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam')--  op' <--    case op of-      Just (op_lam, ne) -> do-        ne' <- internaliseExp "hist_ne" ne-        ne_ts <- mapM I.subExpType ne'-        (lam_params, lam_body, lam_rettype) <--          internaliseLambda op_lam $ ne_ts ++ ne_ts-        idxp <- newParam "idx" $ I.Prim int64-        let op_lam' = I.Lambda (idxp : lam_params) lam_body lam_rettype-        return $ Just (op_lam', ne')-      Nothing ->-        return Nothing--  destw <- arraysSize 0 <$> mapM lookupType dest'-  fmap (map I.Var) $-    letTupExp desc $ WithAcc [(Shape [destw], dest', op')] withacc_lam--internaliseExp1 :: String -> E.Exp -> InternaliseM I.SubExp-internaliseExp1 desc e = do-  vs <- internaliseExp desc e-  case vs of-    [se] -> return se-    _ -> error "Internalise.internaliseExp1: was passed not just a single subexpression"---- | Promote to dimension type as appropriate for the original type.--- Also return original type.-internaliseDimExp :: String -> E.Exp -> InternaliseM (I.SubExp, IntType)-internaliseDimExp s e = do-  e' <- internaliseExp1 s e-  case E.typeOf e of-    E.Scalar (E.Prim (Signed it)) -> (,it) <$> asIntS Int64 e'-    _ -> error "internaliseDimExp: bad type"--internaliseExpToVars :: String -> E.Exp -> InternaliseM [I.VName]-internaliseExpToVars desc e =-  mapM asIdent =<< internaliseExp desc e-  where-    asIdent (I.Var v) = return v-    asIdent se = letExp desc $ I.BasicOp $ I.SubExp se--internaliseOperation ::-  String ->-  E.Exp ->-  (I.VName -> InternaliseM I.BasicOp) ->-  InternaliseM [I.SubExp]-internaliseOperation s e op = do-  vs <- internaliseExpToVars s e-  letSubExps s =<< mapM (fmap I.BasicOp . op) vs--certifyingNonzero ::-  SrcLoc ->-  IntType ->-  SubExp ->-  InternaliseM a ->-  InternaliseM a-certifyingNonzero loc t x m = do-  zero <--    letSubExp "zero" $-      I.BasicOp $-        CmpOp (CmpEq (IntType t)) x (intConst t 0)-  nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero-  c <- assert "nonzero_cert" nonzero "division by zero" loc-  certifying c m--certifyingNonnegative ::-  SrcLoc ->-  IntType ->-  SubExp ->-  InternaliseM a ->-  InternaliseM a-certifyingNonnegative loc t x m = do-  nonnegative <--    letSubExp "nonnegative" $-      I.BasicOp $-        CmpOp (CmpSle t) (intConst t 0) x-  c <- assert "nonzero_cert" nonnegative "negative exponent" loc-  certifying c m--internaliseBinOp ::-  SrcLoc ->-  String ->-  E.BinOp ->-  I.SubExp ->-  I.SubExp ->-  E.PrimType ->-  E.PrimType ->-  InternaliseM [I.SubExp]-internaliseBinOp _ desc E.Plus x y (E.Signed t) _ =-  simpleBinOp desc (I.Add t I.OverflowWrap) x y-internaliseBinOp _ desc E.Plus x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Add t I.OverflowWrap) x y-internaliseBinOp _ desc E.Plus x y (E.FloatType t) _ =-  simpleBinOp desc (I.FAdd t) x y-internaliseBinOp _ desc E.Minus x y (E.Signed t) _ =-  simpleBinOp desc (I.Sub t I.OverflowWrap) x y-internaliseBinOp _ desc E.Minus x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Sub t I.OverflowWrap) x y-internaliseBinOp _ desc E.Minus x y (E.FloatType t) _ =-  simpleBinOp desc (I.FSub t) x y-internaliseBinOp _ desc E.Times x y (E.Signed t) _ =-  simpleBinOp desc (I.Mul t I.OverflowWrap) x y-internaliseBinOp _ desc E.Times x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Mul t I.OverflowWrap) x y-internaliseBinOp _ desc E.Times x y (E.FloatType t) _ =-  simpleBinOp desc (I.FMul t) x y-internaliseBinOp loc desc E.Divide x y (E.Signed t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.SDiv t I.Unsafe) x y-internaliseBinOp loc desc E.Divide x y (E.Unsigned t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.UDiv t I.Unsafe) x y-internaliseBinOp _ desc E.Divide x y (E.FloatType t) _ =-  simpleBinOp desc (I.FDiv t) x y-internaliseBinOp _ desc E.Pow x y (E.FloatType t) _ =-  simpleBinOp desc (I.FPow t) x y-internaliseBinOp loc desc E.Pow x y (E.Signed t) _ =-  certifyingNonnegative loc t y $-    simpleBinOp desc (I.Pow t) x y-internaliseBinOp _ desc E.Pow x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Pow t) x y-internaliseBinOp loc desc E.Mod x y (E.Signed t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.SMod t I.Unsafe) x y-internaliseBinOp loc desc E.Mod x y (E.Unsigned t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.UMod t I.Unsafe) x y-internaliseBinOp _ desc E.Mod x y (E.FloatType t) _ =-  simpleBinOp desc (I.FMod t) x y-internaliseBinOp loc desc E.Quot x y (E.Signed t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.SQuot t I.Unsafe) x y-internaliseBinOp loc desc E.Quot x y (E.Unsigned t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.UDiv t I.Unsafe) x y-internaliseBinOp loc desc E.Rem x y (E.Signed t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.SRem t I.Unsafe) x y-internaliseBinOp loc desc E.Rem x y (E.Unsigned t) _ =-  certifyingNonzero loc t y $-    simpleBinOp desc (I.UMod t I.Unsafe) x y-internaliseBinOp _ desc E.ShiftR x y (E.Signed t) _ =-  simpleBinOp desc (I.AShr t) x y-internaliseBinOp _ desc E.ShiftR x y (E.Unsigned t) _ =-  simpleBinOp desc (I.LShr t) x y-internaliseBinOp _ desc E.ShiftL x y (E.Signed t) _ =-  simpleBinOp desc (I.Shl t) x y-internaliseBinOp _ desc E.ShiftL x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Shl t) x y-internaliseBinOp _ desc E.Band x y (E.Signed t) _ =-  simpleBinOp desc (I.And t) x y-internaliseBinOp _ desc E.Band x y (E.Unsigned t) _ =-  simpleBinOp desc (I.And t) x y-internaliseBinOp _ desc E.Xor x y (E.Signed t) _ =-  simpleBinOp desc (I.Xor t) x y-internaliseBinOp _ desc E.Xor x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Xor t) x y-internaliseBinOp _ desc E.Bor x y (E.Signed t) _ =-  simpleBinOp desc (I.Or t) x y-internaliseBinOp _ desc E.Bor x y (E.Unsigned t) _ =-  simpleBinOp desc (I.Or t) x y-internaliseBinOp _ desc E.Equal x y t _ =-  simpleCmpOp desc (I.CmpEq $ internalisePrimType t) x y-internaliseBinOp _ desc E.NotEqual x y t _ = do-  eq <- letSubExp (desc ++ "true") $ I.BasicOp $ I.CmpOp (I.CmpEq $ internalisePrimType t) x y-  fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp I.Not eq-internaliseBinOp _ desc E.Less x y (E.Signed t) _ =-  simpleCmpOp desc (I.CmpSlt t) x y-internaliseBinOp _ desc E.Less x y (E.Unsigned t) _ =-  simpleCmpOp desc (I.CmpUlt t) x y-internaliseBinOp _ desc E.Leq x y (E.Signed t) _ =-  simpleCmpOp desc (I.CmpSle t) x y-internaliseBinOp _ desc E.Leq x y (E.Unsigned t) _ =-  simpleCmpOp desc (I.CmpUle t) x y-internaliseBinOp _ desc E.Greater x y (E.Signed t) _ =-  simpleCmpOp desc (I.CmpSlt t) y x -- Note the swapped x and y-internaliseBinOp _ desc E.Greater x y (E.Unsigned t) _ =-  simpleCmpOp desc (I.CmpUlt t) y x -- Note the swapped x and y-internaliseBinOp _ desc E.Geq x y (E.Signed t) _ =-  simpleCmpOp desc (I.CmpSle t) y x -- Note the swapped x and y-internaliseBinOp _ desc E.Geq x y (E.Unsigned t) _ =-  simpleCmpOp desc (I.CmpUle t) y x -- Note the swapped x and y-internaliseBinOp _ desc E.Less x y (E.FloatType t) _ =-  simpleCmpOp desc (I.FCmpLt t) x y-internaliseBinOp _ desc E.Leq x y (E.FloatType t) _ =-  simpleCmpOp desc (I.FCmpLe t) x y-internaliseBinOp _ desc E.Greater x y (E.FloatType t) _ =-  simpleCmpOp desc (I.FCmpLt t) y x -- Note the swapped x and y-internaliseBinOp _ desc E.Geq x y (E.FloatType t) _ =-  simpleCmpOp desc (I.FCmpLe t) y x -- Note the swapped x and y---- Relational operators for booleans.-internaliseBinOp _ desc E.Less x y E.Bool _ =-  simpleCmpOp desc I.CmpLlt x y-internaliseBinOp _ desc E.Leq x y E.Bool _ =-  simpleCmpOp desc I.CmpLle x y-internaliseBinOp _ desc E.Greater x y E.Bool _ =-  simpleCmpOp desc I.CmpLlt y x -- Note the swapped x and y-internaliseBinOp _ desc E.Geq x y E.Bool _ =-  simpleCmpOp desc I.CmpLle y x -- Note the swapped x and y-internaliseBinOp _ _ op _ _ t1 t2 =-  error $-    "Invalid binary operator " ++ pretty op-      ++ " with operand types "-      ++ pretty t1-      ++ ", "-      ++ pretty t2--simpleBinOp ::-  String ->-  I.BinOp ->-  I.SubExp ->-  I.SubExp ->-  InternaliseM [I.SubExp]-simpleBinOp desc bop x y =-  letTupExp' desc $ I.BasicOp $ I.BinOp bop x y--simpleCmpOp ::-  String ->-  I.CmpOp ->-  I.SubExp ->-  I.SubExp ->-  InternaliseM [I.SubExp]-simpleCmpOp desc op x y =-  letTupExp' desc $ I.BasicOp $ I.CmpOp op x y--findFuncall ::-  E.AppExp ->-  InternaliseM-    ( E.QualName VName,-      [(E.Exp, Maybe VName)]-    )-findFuncall (E.Apply f arg (Info (_, argext)) _)-  | E.AppExp f_e _ <- f = do-    (fname, args) <- findFuncall f_e-    return (fname, args ++ [(arg, argext)])-  | E.Var fname _ _ <- f =-    return (fname, [(arg, argext)])-findFuncall e =-  error $ "Invalid function expression in application: " ++ pretty e---- The type of a body.  Watch out: this only works for the degenerate--- case where the body does not already return its context.-bodyExtType :: Body -> InternaliseM [ExtType]-bodyExtType (Body _ stms res) =-  existentialiseExtTypes (M.keys stmsscope) . staticShapes-    <$> extendedScope (traverse subExpType res) stmsscope-  where-    stmsscope = scopeOf stms--internaliseLambda :: InternaliseLambda-internaliseLambda (E.Parens e _) rowtypes =-  internaliseLambda e rowtypes-internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =-  bindingLambdaParams params rowtypes $ \params' -> do-    body' <- internaliseBody "lam" body-    rettype' <- internaliseLambdaReturnType rettype =<< bodyExtType body'-    return (params', body', rettype')-internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e---- | Some operators and functions are overloaded or otherwise special--- - we detect and treat them here.-isOverloadedFunction ::-  E.QualName VName ->-  [E.Exp] ->-  SrcLoc ->-  Maybe (String -> InternaliseM [SubExp])-isOverloadedFunction qname args loc = do-  guard $ baseTag (qualLeaf qname) <= maxIntrinsicTag-  let handlers =-        [ handleSign,-          handleIntrinsicOps,-          handleOps,-          handleSOACs,-          handleAccs,-          handleRest-        ]-  msum [h args $ baseString $ qualLeaf qname | h <- handlers]-  where-    handleSign [x] "sign_i8" = Just $ toSigned I.Int8 x-    handleSign [x] "sign_i16" = Just $ toSigned I.Int16 x-    handleSign [x] "sign_i32" = Just $ toSigned I.Int32 x-    handleSign [x] "sign_i64" = Just $ toSigned I.Int64 x-    handleSign [x] "unsign_i8" = Just $ toUnsigned I.Int8 x-    handleSign [x] "unsign_i16" = Just $ toUnsigned I.Int16 x-    handleSign [x] "unsign_i32" = Just $ toUnsigned I.Int32 x-    handleSign [x] "unsign_i64" = Just $ toUnsigned I.Int64 x-    handleSign _ _ = Nothing--    handleIntrinsicOps [x] s-      | Just unop <- find ((== s) . pretty) allUnOps = Just $ \desc -> do-        x' <- internaliseExp1 "x" x-        fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp unop x'-    handleIntrinsicOps [TupLit [x, y] _] s-      | Just bop <- find ((== s) . pretty) allBinOps = Just $ \desc -> do-        x' <- internaliseExp1 "x" x-        y' <- internaliseExp1 "y" y-        fmap pure $ letSubExp desc $ I.BasicOp $ I.BinOp bop x' y'-      | Just cmp <- find ((== s) . pretty) allCmpOps = Just $ \desc -> do-        x' <- internaliseExp1 "x" x-        y' <- internaliseExp1 "y" y-        fmap pure $ letSubExp desc $ I.BasicOp $ I.CmpOp cmp x' y'-    handleIntrinsicOps [x] s-      | Just conv <- find ((== s) . pretty) allConvOps = Just $ \desc -> do-        x' <- internaliseExp1 "x" x-        fmap pure $ letSubExp desc $ I.BasicOp $ I.ConvOp conv x'-    handleIntrinsicOps _ _ = Nothing--    -- Short-circuiting operators are magical.-    handleOps [x, y] "&&" = Just $ \desc ->-      internaliseExp desc $-        E.AppExp-          (E.If x y (E.Literal (E.BoolValue False) mempty) mempty)-          (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])-    handleOps [x, y] "||" = Just $ \desc ->-      internaliseExp desc $-        E.AppExp-          (E.If x (E.Literal (E.BoolValue True) mempty) y mempty)-          (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])-    -- Handle equality and inequality specially, to treat the case of-    -- arrays.-    handleOps [xe, ye] op-      | Just cmp_f <- isEqlOp op = Just $ \desc -> do-        xe' <- internaliseExp "x" xe-        ye' <- internaliseExp "y" ye-        rs <- zipWithM (doComparison desc) xe' ye'-        cmp_f desc =<< letSubExp "eq" =<< eAll rs-      where-        isEqlOp "!=" = Just $ \desc eq ->-          letTupExp' desc $ I.BasicOp $ I.UnOp I.Not eq-        isEqlOp "==" = Just $ \_ eq ->-          return [eq]-        isEqlOp _ = Nothing--        doComparison desc x y = do-          x_t <- I.subExpType x-          y_t <- I.subExpType y-          case x_t of-            I.Prim t -> letSubExp desc $ I.BasicOp $ I.CmpOp (I.CmpEq t) x y-            _ -> do-              let x_dims = I.arrayDims x_t-                  y_dims = I.arrayDims y_t-              dims_match <- forM (zip x_dims y_dims) $ \(x_dim, y_dim) ->-                letSubExp "dim_eq" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) x_dim y_dim-              shapes_match <- letSubExp "shapes_match" =<< eAll dims_match-              compare_elems_body <- runBodyBinder $ do-                -- Flatten both x and y.-                x_num_elems <--                  letSubExp "x_num_elems"-                    =<< foldBinOp (I.Mul Int64 I.OverflowUndef) (constant (1 :: Int64)) x_dims-                x' <- letExp "x" $ I.BasicOp $ I.SubExp x-                y' <- letExp "x" $ I.BasicOp $ I.SubExp y-                x_flat <- letExp "x_flat" $ I.BasicOp $ I.Reshape [I.DimNew x_num_elems] x'-                y_flat <- letExp "y_flat" $ I.BasicOp $ I.Reshape [I.DimNew x_num_elems] y'--                -- Compare the elements.-                cmp_lam <- cmpOpLambda $ I.CmpEq (elemType x_t)-                cmps <--                  letExp "cmps" $-                    I.Op $-                      I.Screma x_num_elems [x_flat, y_flat] (I.mapSOAC cmp_lam)--                -- Check that all were equal.-                and_lam <- binOpLambda I.LogAnd I.Bool-                reduce <- I.reduceSOAC [Reduce Commutative and_lam [constant True]]-                all_equal <- letSubExp "all_equal" $ I.Op $ I.Screma x_num_elems [cmps] reduce-                return $ resultBody [all_equal]--              letSubExp "arrays_equal" $-                I.If shapes_match compare_elems_body (resultBody [constant False]) $-                  ifCommon [I.Prim I.Bool]-    handleOps [x, y] name-      | Just bop <- find ((name ==) . pretty) [minBound .. maxBound :: E.BinOp] =-        Just $ \desc -> do-          x' <- internaliseExp1 "x" x-          y' <- internaliseExp1 "y" y-          case (E.typeOf x, E.typeOf y) of-            (E.Scalar (E.Prim t1), E.Scalar (E.Prim t2)) ->-              internaliseBinOp loc desc bop x' y' t1 t2-            _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in BinOp."-    handleOps _ _ = Nothing--    handleSOACs [TupLit [lam, arr] _] "map" = Just $ \desc -> do-      arr' <- internaliseExpToVars "map_arr" arr-      lam' <- internaliseMapLambda internaliseLambda lam $ map I.Var arr'-      w <- arraysSize 0 <$> mapM lookupType arr'-      letTupExp' desc $-        I.Op $-          I.Screma w arr' (I.mapSOAC lam')-    handleSOACs [TupLit [k, lam, arr] _] "partition" = do-      k' <- fromIntegral <$> fromInt32 k-      Just $ \_desc -> do-        arrs <- internaliseExpToVars "partition_input" arr-        lam' <- internalisePartitionLambda internaliseLambda k' lam $ map I.Var arrs-        uncurry (++) <$> partitionWithSOACS (fromIntegral k') lam' arrs-      where-        fromInt32 (Literal (SignedValue (Int32Value k')) _) = Just k'-        fromInt32 (IntLit k' (Info (E.Scalar (E.Prim (Signed Int32)))) _) = Just $ fromInteger k'-        fromInt32 _ = Nothing-    handleSOACs [TupLit [lam, ne, arr] _] "reduce" = Just $ \desc ->-      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)-      where-        reduce w red_lam nes arrs =-          I.Screma w arrs-            <$> I.reduceSOAC [Reduce Noncommutative red_lam nes]-    handleSOACs [TupLit [lam, ne, arr] _] "reduce_comm" = Just $ \desc ->-      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)-      where-        reduce w red_lam nes arrs =-          I.Screma w arrs-            <$> I.reduceSOAC [Reduce Commutative red_lam nes]-    handleSOACs [TupLit [lam, ne, arr] _] "scan" = Just $ \desc ->-      internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc)-      where-        reduce w scan_lam nes arrs =-          I.Screma w arrs <$> I.scanSOAC [Scan scan_lam nes]-    handleSOACs [TupLit [op, f, arr] _] "reduce_stream" = Just $ \desc ->-      internaliseStreamRed desc InOrder Noncommutative op f arr-    handleSOACs [TupLit [op, f, arr] _] "reduce_stream_per" = Just $ \desc ->-      internaliseStreamRed desc Disorder Commutative op f arr-    handleSOACs [TupLit [f, arr] _] "map_stream" = Just $ \desc ->-      internaliseStreamMap desc InOrder f arr-    handleSOACs [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->-      internaliseStreamMap desc Disorder f arr-    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->-      internaliseHist desc rf dest op ne buckets img loc-    handleSOACs _ _ = Nothing--    handleAccs [TupLit [dest, f, bs] _] "scatter_stream" = Just $ \desc ->-      internaliseStreamAcc desc dest Nothing f bs-    handleAccs [TupLit [dest, op, ne, f, bs] _] "hist_stream" = Just $ \desc ->-      internaliseStreamAcc desc dest (Just (op, ne)) f bs-    handleAccs [TupLit [acc, i, v] _] "acc_write" = Just $ \desc -> do-      acc' <- head <$> internaliseExpToVars "acc" acc-      i' <- internaliseExp1 "acc_i" i-      vs <- internaliseExp "acc_v" v-      fmap pure $ letSubExp desc $ BasicOp $ UpdateAcc acc' [i'] vs-    handleAccs _ _ = Nothing--    handleRest [x] "!" = Just $ complementF x-    handleRest [x] "opaque" = Just $ \desc ->-      mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x-    handleRest [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF 1 a si v-    handleRest [E.TupLit [a, si, v] _] "scatter_2d" = Just $ scatterF 2 a si v-    handleRest [E.TupLit [a, si, v] _] "scatter_3d" = Just $ scatterF 3 a si v-    handleRest [E.TupLit [n, m, arr] _] "unflatten" = Just $ \desc -> do-      arrs <- internaliseExpToVars "unflatten_arr" arr-      n' <- internaliseExp1 "n" n-      m' <- internaliseExp1 "m" m-      -- The unflattened dimension needs to have the same number of elements-      -- as the original dimension.-      old_dim <- I.arraysSize 0 <$> mapM lookupType arrs-      dim_ok <--        letSubExp "dim_ok"-          =<< eCmpOp-            (I.CmpEq I.int64)-            (eBinOp (I.Mul Int64 I.OverflowUndef) (eSubExp n') (eSubExp m'))-            (eSubExp old_dim)-      dim_ok_cert <--        assert-          "dim_ok_cert"-          dim_ok-          "new shape has different number of elements than old shape"-          loc-      certifying dim_ok_cert $-        forM arrs $ \arr' -> do-          arr_t <- lookupType arr'-          letSubExp desc $-            I.BasicOp $-              I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ I.arrayShape arr_t) arr'-    handleRest [arr] "flatten" = Just $ \desc -> do-      arrs <- internaliseExpToVars "flatten_arr" arr-      forM arrs $ \arr' -> do-        arr_t <- lookupType arr'-        let n = arraySize 0 arr_t-            m = arraySize 1 arr_t-        k <- letSubExp "flat_dim" $ I.BasicOp $ I.BinOp (Mul Int64 I.OverflowUndef) n m-        letSubExp desc $-          I.BasicOp $-            I.Reshape (reshapeOuter [DimNew k] 2 $ I.arrayShape arr_t) arr'-    handleRest [TupLit [x, y] _] "concat" = Just $ \desc -> do-      xs <- internaliseExpToVars "concat_x" x-      ys <- internaliseExpToVars "concat_y" y-      outer_size <- arraysSize 0 <$> mapM lookupType xs-      let sumdims xsize ysize =-            letSubExp "conc_tmp" $-              I.BasicOp $-                I.BinOp (I.Add I.Int64 I.OverflowUndef) xsize ysize-      ressize <--        foldM sumdims outer_size-          =<< mapM (fmap (arraysSize 0) . mapM lookupType) [ys]--      let conc xarr yarr =-            I.BasicOp $ I.Concat 0 xarr [yarr] ressize-      letSubExps desc $ zipWith conc xs ys-    handleRest [TupLit [offset, e] _] "rotate" = Just $ \desc -> do-      offset' <- internaliseExp1 "rotation_offset" offset-      internaliseOperation desc e $ \v -> do-        r <- I.arrayRank <$> lookupType v-        let zero = intConst Int64 0-            offsets = offset' : replicate (r -1) zero-        return $ I.Rotate offsets v-    handleRest [e] "transpose" = Just $ \desc ->-      internaliseOperation desc e $ \v -> do-        r <- I.arrayRank <$> lookupType v-        return $ I.Rearrange ([1, 0] ++ [2 .. r -1]) v-    handleRest [TupLit [x, y] _] "zip" = Just $ \desc ->-      mapM (letSubExp "zip_copy" . BasicOp . Copy)-        =<< ( (++)-                <$> internaliseExpToVars (desc ++ "_zip_x") x-                <*> internaliseExpToVars (desc ++ "_zip_y") y-            )-    handleRest [x] "unzip" = Just $ flip internaliseExp x-    handleRest [x] "trace" = Just $ flip internaliseExp x-    handleRest [x] "break" = Just $ flip internaliseExp x-    handleRest _ _ = Nothing--    toSigned int_to e desc = do-      e' <- internaliseExp1 "trunc_arg" e-      case E.typeOf e of-        E.Scalar (E.Prim E.Bool) ->-          letTupExp' desc $-            I.If-              e'-              (resultBody [intConst int_to 1])-              (resultBody [intConst int_to 0])-              $ ifCommon [I.Prim $ I.IntType int_to]-        E.Scalar (E.Prim (E.Signed int_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.SExt int_from int_to) e'-        E.Scalar (E.Prim (E.Unsigned int_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'-        E.Scalar (E.Prim (E.FloatType float_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToSI float_from int_to) e'-        _ -> error "Futhark.Internalise: non-numeric type in ToSigned"--    toUnsigned int_to e desc = do-      e' <- internaliseExp1 "trunc_arg" e-      case E.typeOf e of-        E.Scalar (E.Prim E.Bool) ->-          letTupExp' desc $-            I.If-              e'-              (resultBody [intConst int_to 1])-              (resultBody [intConst int_to 0])-              $ ifCommon [I.Prim $ I.IntType int_to]-        E.Scalar (E.Prim (E.Signed int_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'-        E.Scalar (E.Prim (E.Unsigned int_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'-        E.Scalar (E.Prim (E.FloatType float_from)) ->-          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToUI float_from int_to) e'-        _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in ToUnsigned"--    complementF e desc = do-      e' <- internaliseExp1 "complement_arg" e-      et <- subExpType e'-      case et of-        I.Prim (I.IntType t) ->-          letTupExp' desc $ I.BasicOp $ I.UnOp (I.Complement t) e'-        I.Prim I.Bool ->-          letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e'-        _ ->-          error "Futhark.Internalise.internaliseExp: non-int/bool type in Complement"--    scatterF dim a si v desc = do-      si' <- internaliseExpToVars "write_arg_i" si-      svs <- internaliseExpToVars "write_arg_v" v-      sas <- internaliseExpToVars "write_arg_a" a--      si_w <- I.arraysSize 0 <$> mapM lookupType si'-      sv_ts <- mapM lookupType svs--      svs' <- forM (zip svs sv_ts) $ \(sv, sv_t) -> do-        let sv_shape = I.arrayShape sv_t-            sv_w = arraySize 0 sv_t--        -- Generate an assertion and reshapes to ensure that sv and si' are the same-        -- size.-        cmp <--          letSubExp "write_cmp" $-            I.BasicOp $-              I.CmpOp (I.CmpEq I.int64) si_w sv_w-        c <--          assert-            "write_cert"-            cmp-            "length of index and value array does not match"-            loc-        certifying c $-          letExp (baseString sv ++ "_write_sv") $-            I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion si_w] 1 sv_shape) sv--      indexType <- fmap rowType <$> mapM lookupType si'-      indexName <- mapM (\_ -> newVName "write_index") indexType-      valueNames <- replicateM (length sv_ts) $ newVName "write_value"--      sa_ts <- mapM lookupType sas-      let bodyTypes = concat (replicate (length sv_ts) indexType) ++ map (I.stripArray dim) sa_ts-          paramTypes = indexType <> map rowType sv_ts-          bodyNames = indexName <> valueNames-          bodyParams = zipWith I.Param bodyNames paramTypes--      -- This body is pretty boring right now, as every input is exactly the output.-      -- But it can get funky later on if fused with something else.-      body <- localScope (scopeOfLParams bodyParams) . buildBody_ $ do-        let outs = concat (replicate (length valueNames) indexName) ++ valueNames-        results <- forM outs $ \name ->-          letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name-        ensureResultShape-          "scatter value has wrong size"-          loc-          bodyTypes-          results--      let lam =-            I.Lambda-              { I.lambdaParams = bodyParams,-                I.lambdaReturnType = bodyTypes,-                I.lambdaBody = body-              }-          sivs = si' <> svs'--      let sa_ws = map (Shape . take dim . arrayDims) sa_ts-      letTupExp' desc $ I.Op $ I.Scatter si_w lam sivs $ zip3 sa_ws (repeat 1) sas--funcall ::-  String ->-  QualName VName ->-  [SubExp] ->-  SrcLoc ->-  InternaliseM ([SubExp], [I.ExtType])-funcall desc (QualName _ fname) args loc = do-  (shapes, value_paramts, fun_params, rettype_fun) <--    lookupFunction fname-  argts <- mapM subExpType args--  shapeargs <- argShapes shapes fun_params argts-  let diets =-        replicate (length shapeargs) I.ObservePrim-          ++ map I.diet value_paramts-  args' <--    ensureArgShapes-      "function arguments of wrong shape"-      loc-      (map I.paramName fun_params)-      (map I.paramType fun_params)-      (shapeargs ++ args)-  argts' <- mapM subExpType args'-  case rettype_fun $ zip args' argts' of-    Nothing ->-      error $-        concat-          [ "Cannot apply ",-            pretty fname,-            " to ",-            show (length args'),-            " arguments\n ",-            pretty args',-            "\nof types\n ",-            pretty argts',-            "\nFunction has ",-            show (length fun_params),-            " parameters\n ",-            pretty fun_params-          ]-    Just ts -> do-      safety <- askSafety-      attrs <- asks envAttrs-      ses <--        attributing attrs $-          letTupExp' desc $-            I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)-      return (ses, map I.fromDecl ts)---- Bind existential names defined by an expression, based on the--- concrete values that expression evaluated to.  This most--- importantly should be done after function calls, but also--- everything else that can produce existentials in the source--- language.-bindExtSizes :: AppRes -> [SubExp] -> InternaliseM ()-bindExtSizes (AppRes ret retext) ses = do-  ts <- internaliseType $ E.toStruct ret-  ses_ts <- mapM subExpType ses--  let combine t1 t2 =-        mconcat $ zipWith combine' (arrayExtDims t1) (arrayDims t2)-      combine' (I.Free (I.Var v)) se-        | v `elem` retext = M.singleton v se-      combine' _ _ = mempty--  forM_ (M.toList $ mconcat $ zipWith combine ts ses_ts) $ \(v, se) ->-    letBindNames [v] $ BasicOp $ SubExp se--askSafety :: InternaliseM Safety-askSafety = do-  check <- asks envDoBoundsChecks-  return $ if check then I.Safe else I.Unsafe---- Implement partitioning using maps, scans and writes.-partitionWithSOACS :: Int -> I.Lambda -> [I.VName] -> InternaliseM ([I.SubExp], [I.SubExp])-partitionWithSOACS k lam arrs = do-  arr_ts <- mapM lookupType arrs-  let w = arraysSize 0 arr_ts-  classes_and_increments <- letTupExp "increments" $ I.Op $ I.Screma w arrs (mapSOAC lam)-  (classes, increments) <- case classes_and_increments of-    classes : increments -> return (classes, take k increments)-    _ -> error "partitionWithSOACS"--  add_lam_x_params <--    replicateM k $ I.Param <$> newVName "x" <*> pure (I.Prim int64)-  add_lam_y_params <--    replicateM k $ I.Param <$> newVName "y" <*> pure (I.Prim int64)-  add_lam_body <- runBodyBinder $-    localScope (scopeOfLParams $ add_lam_x_params ++ add_lam_y_params) $-      fmap resultBody $-        forM (zip add_lam_x_params add_lam_y_params) $ \(x, y) ->-          letSubExp "z" $-            I.BasicOp $-              I.BinOp-                (I.Add Int64 I.OverflowUndef)-                (I.Var $ I.paramName x)-                (I.Var $ I.paramName y)-  let add_lam =-        I.Lambda-          { I.lambdaBody = add_lam_body,-            I.lambdaParams = add_lam_x_params ++ add_lam_y_params,-            I.lambdaReturnType = replicate k $ I.Prim int64-          }-      nes = replicate (length increments) $ intConst Int64 0--  scan <- I.scanSOAC [I.Scan add_lam nes]-  all_offsets <- letTupExp "offsets" $ I.Op $ I.Screma w increments scan--  -- We have the offsets for each of the partitions, but we also need-  -- the total sizes, which are the last elements in the offests.  We-  -- just have to be careful in case the array is empty.-  last_index <- letSubExp "last_index" $ I.BasicOp $ I.BinOp (I.Sub Int64 OverflowUndef) w $ constant (1 :: Int64)-  nonempty_body <- runBodyBinder $-    fmap resultBody $-      forM all_offsets $ \offset_array ->-        letSubExp "last_offset" $ I.BasicOp $ I.Index offset_array [I.DimFix last_index]-  let empty_body = resultBody $ replicate k $ constant (0 :: Int64)-  is_empty <- letSubExp "is_empty" $ I.BasicOp $ I.CmpOp (CmpEq int64) w $ constant (0 :: Int64)-  sizes <--    letTupExp "partition_size" $-      I.If is_empty empty_body nonempty_body $-        ifCommon $ replicate k $ I.Prim int64--  -- The total size of all partitions must necessarily be equal to the-  -- size of the input array.--  -- Create scratch arrays for the result.-  blanks <- forM arr_ts $ \arr_t ->-    letExp "partition_dest" $-      I.BasicOp $ Scratch (I.elemType arr_t) (w : drop 1 (I.arrayDims arr_t))--  -- Now write into the result.-  write_lam <- do-    c_param <- I.Param <$> newVName "c" <*> pure (I.Prim int64)-    offset_params <- replicateM k $ I.Param <$> newVName "offset" <*> pure (I.Prim int64)-    value_params <- forM arr_ts $ \arr_t ->-      I.Param <$> newVName "v" <*> pure (I.rowType arr_t)-    (offset, offset_stms) <--      collectStms $-        mkOffsetLambdaBody-          (map I.Var sizes)-          (I.Var $ I.paramName c_param)-          0-          offset_params-    return-      I.Lambda-        { I.lambdaParams = c_param : offset_params ++ value_params,-          I.lambdaReturnType =-            replicate (length arr_ts) (I.Prim int64)-              ++ map I.rowType arr_ts,-          I.lambdaBody =-            mkBody offset_stms $-              replicate (length arr_ts) offset-                ++ map (I.Var . I.paramName) value_params-        }-  results <--    letTupExp "partition_res" $-      I.Op $-        I.Scatter-          w-          write_lam-          (classes : all_offsets ++ arrs)-          $ zip3 (repeat $ Shape [w]) (repeat 1) blanks-  sizes' <--    letSubExp "partition_sizes" $-      I.BasicOp $-        I.ArrayLit (map I.Var sizes) $ I.Prim int64-  return (map I.Var results, [sizes'])-  where-    mkOffsetLambdaBody ::-      [SubExp] ->-      SubExp ->-      Int ->-      [I.LParam] ->-      InternaliseM SubExp-    mkOffsetLambdaBody _ _ _ [] =-      return $ constant (-1 :: Int64)-    mkOffsetLambdaBody sizes c i (p : ps) = do-      is_this_one <--        letSubExp "is_this_one" $-          I.BasicOp $-            I.CmpOp (CmpEq int64) c $-              intConst Int64 $ toInteger i-      next_one <- mkOffsetLambdaBody sizes c (i + 1) ps-      this_one <--        letSubExp "this_offset"-          =<< foldBinOp-            (Add Int64 OverflowUndef)-            (constant (-1 :: Int64))-            (I.Var (I.paramName p) : take i sizes)-      letSubExp "total_res" $-        I.If-          is_this_one-          (resultBody [this_one])-          (resultBody [next_one])-          $ ifCommon [I.Prim int64]--typeExpForError :: E.TypeExp VName -> InternaliseM [ErrorMsgPart SubExp]-typeExpForError (E.TEVar qn _) =-  return [ErrorString $ pretty qn]-typeExpForError (E.TEUnique te _) =-  ("*" :) <$> typeExpForError te-typeExpForError (E.TEArray te d _) = do-  d' <- dimExpForError d-  te' <- typeExpForError te-  return $ ["[", d', "]"] ++ te'-typeExpForError (E.TETuple tes _) = do-  tes' <- mapM typeExpForError tes-  return $ ["("] ++ intercalate [", "] tes' ++ [")"]-typeExpForError (E.TERecord fields _) = do-  fields' <- mapM onField fields-  return $ ["{"] ++ intercalate [", "] fields' ++ ["}"]-  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 (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 (E.TESum cs _) = do-  cs' <- mapM (onClause . snd) cs-  return $ intercalate [" | "] cs'-  where-    onClause c = do-      c' <- mapM typeExpForError c-      return $ intercalate [" "] c'--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 $ ErrorInt64 d'-dimExpForError (DimExpConst d _) =-  return $ ErrorString $ pretty d-dimExpForError DimExpAny = return ""---- A smart constructor that compacts neighbouring literals for easier--- reading in the IR.-errorMsg :: [ErrorMsgPart a] -> ErrorMsg a-errorMsg = ErrorMsg . compact-  where-    compact [] = []-    compact (ErrorString x : ErrorString y : parts) =-      compact (ErrorString (x ++ y) : parts)-    compact (x : y) = x : compact y+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++-- |+--+-- This module implements a transformation from source to core+-- Futhark.+module Futhark.Internalise (internaliseProg) where++import qualified Data.Text as T+import Futhark.Compiler.Config+import Futhark.IR.SOACS as I hiding (stmPattern)+import Futhark.Internalise.Defunctionalise as Defunctionalise+import Futhark.Internalise.Defunctorise as Defunctorise+import qualified Futhark.Internalise.Exps as Exps+import Futhark.Internalise.LiftLambdas as LiftLambdas+import Futhark.Internalise.Monad as I+import Futhark.Internalise.Monomorphise as Monomorphise+import Futhark.Util.Log+import Language.Futhark.Semantic (Imports)++-- | Convert a program in source Futhark to a program in the Futhark+-- core language.+internaliseProg ::+  (MonadFreshNames m, MonadLogger m) =>+  FutharkConfig ->+  Imports ->+  m (I.Prog SOACS)+internaliseProg config prog = do+  maybeLog "Defunctorising"+  prog_decs <- Defunctorise.transformProg prog+  maybeLog "Monomorphising"+  prog_decs' <- Monomorphise.transformProg prog_decs+  maybeLog "Lifting lambdas"+  prog_decs'' <- LiftLambdas.transformProg prog_decs'+  maybeLog "Defunctionalising"+  prog_decs''' <- Defunctionalise.transformProg prog_decs''+  maybeLog "Converting to core IR"+  Exps.transformProg (futharkSafe config) prog_decs'''+  where+    verbose = fst (futharkVerbose config) > NotVerbose+    maybeLog s+      | verbose = logMsg (s :: T.Text)+      | otherwise = pure ()

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Strict #-}  -- | Internalising bindings. module Futhark.Internalise.Bindings@@ -83,30 +84,23 @@   where     processFlatPattern' pat [] _ = do       let (vs, substs) = unzip pat-          substs' = M.fromList substs-          idents = reverse vs-      return (idents, substs')+      return (reverse vs, M.fromList substs)     processFlatPattern' pat (p : rest) ts = do-      (ps, subst, rest_ts) <- handleMapping ts <$> internaliseBindee p-      processFlatPattern' ((ps, (E.identName p, map (I.Var . I.paramName) subst)) : pat) rest rest_ts+      (ps, rest_ts) <- handleMapping ts <$> internaliseBindee p+      processFlatPattern' ((ps, (E.identName p, map (I.Var . I.paramName) ps)) : pat) rest rest_ts      handleMapping ts [] =-      ([], [], ts)-    handleMapping ts (r : rs) =-      let (ps, reps, ts') = handleMapping' ts r-          (pss, repss, ts'') = handleMapping ts' rs-       in (ps ++ pss, reps : repss, ts'')--    handleMapping' (t : ts) vname =-      let v' = I.Param vname t-       in ([v'], v', ts)-    handleMapping' [] _ =-      error $ "processFlatPattern: insufficient identifiers in pattern." ++ show (x, y)+      ([], ts)+    handleMapping (t : ts) (r : rs) =+      let (ps, ts') = handleMapping ts rs+       in (I.Param r t : ps, ts')+    handleMapping [] _ =+      error $ "handleMapping: insufficient identifiers in pattern." ++ show (x, y)      internaliseBindee :: E.Ident -> InternaliseM [VName]     internaliseBindee bindee = do       let name = E.identName bindee-      n <- internalisedTypeSize $ flip E.setAliases () $ E.unInfo $ E.identType bindee+      n <- internalisedTypeSize $ E.unInfo $ E.identType bindee       case n of         1 -> return [name]         _ -> replicateM n $ newVName $ baseString name@@ -122,8 +116,7 @@   local (\env -> env {envSubsts = substs `M.union` envSubsts env}) $     m ps --- | Flatten a pattern.  Returns a list of identifiers.  The--- structural type of each identifier is returned separately.+-- | Flatten a pattern.  Returns a list of identifiers. flattenPattern :: MonadFreshNames m => E.Pattern -> m [E.Ident] flattenPattern = flattenPattern'   where@@ -157,6 +150,4 @@   InternaliseM a stmPattern pat ts m = do   pat' <- flattenPattern pat-  let addShapeStms l =-        m (map I.paramName $ concat l)-  bindingFlatPattern pat' ts addShapeStms+  bindingFlatPattern pat' ts $ m . map I.paramName . concat

@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TupleSections #-}  -- | Defunctionalization of typed, monomorphic Futhark programs without modules.@@ -8,7 +8,7 @@  import qualified Control.Arrow as Arrow import Control.Monad.Identity-import Control.Monad.RWS hiding (Sum)+import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor import Data.Bitraversable@@ -17,7 +17,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Maybe-import qualified Data.Sequence as Seq import qualified Data.Set as S import Futhark.IR.Pretty () import qualified Futhark.Internalise.FreeVars as FV@@ -203,7 +202,7 @@ -- | Returns the defunctionalization environment restricted -- to the given set of variable names and types. restrictEnvTo :: FV.NameSet -> DefM Env-restrictEnvTo (FV.NameSet m) = restrict <$> ask+restrictEnvTo (FV.NameSet m) = asks restrict   where     restrict (globals, env) = M.mapMaybeWithKey keep env       where@@ -230,25 +229,29 @@ -- the current Env as well as the set of globally defined dynamic -- functions.  This is used to avoid unnecessarily large closure -- environments.-newtype DefM a = DefM (RWS (S.Set VName, Env) (Seq.Seq ValBind) VNameSource a)+newtype DefM a+  = DefM (ReaderT (S.Set VName, Env) (State ([ValBind], VNameSource)) a)   deriving     ( Functor,       Applicative,       Monad,       MonadReader (S.Set VName, Env),-      MonadWriter (Seq.Seq ValBind),-      MonadFreshNames+      MonadState ([ValBind], VNameSource)     ) +instance MonadFreshNames DefM where+  putNameSource src = modify $ \(x, _) -> (x, src)+  getNameSource = gets snd+ -- | Run a computation in the defunctionalization monad. Returns the result of -- the computation, a new name source, and a list of lifted function declations.-runDefM :: VNameSource -> DefM a -> (a, VNameSource, Seq.Seq ValBind)-runDefM src (DefM m) = runRWS m mempty src+runDefM :: VNameSource -> DefM a -> (a, VNameSource, [ValBind])+runDefM src (DefM m) =+  let (x, (vbs, src')) = runState (runReaderT m mempty) (mempty, src)+   in (x, src', reverse vbs) -collectFuns :: DefM a -> DefM (a, Seq.Seq ValBind)-collectFuns m = pass $ do-  (x, decs) <- listen m-  return ((x, decs), const mempty)+addValBind :: ValBind -> DefM ()+addValBind vb = modify $ first (vb :)  -- | Looks up the associated static value for a given name in the environment. lookupVar :: StructType -> VName -> DefM StaticVal@@ -1011,7 +1014,7 @@ -- | Create a new top-level value declaration with the given function name, -- return type, list of parameters, and body expression. liftValDec :: VName -> PatternType -> [VName] -> [Pattern] -> Exp -> DefM ()-liftValDec fname rettype dims pats body = tell $ Seq.singleton dec+liftValDec fname rettype dims pats body = addValBind dec   where     dims' = map (`TypeParamDim` mempty) dims     -- FIXME: this pass is still not correctly size-preserving, so@@ -1283,16 +1286,15 @@     )  -- | Defunctionalize a list of top-level declarations.-defuncVals :: [ValBind] -> DefM (Seq.Seq ValBind)-defuncVals [] = return mempty+defuncVals :: [ValBind] -> DefM ()+defuncVals [] = pure () defuncVals (valbind : ds) = do-  ((valbind', env, dyn), defs) <- collectFuns $ defuncValBind valbind-  ds' <--    localEnv env $-      if dyn-        then isGlobal (valBindName valbind') $ defuncVals ds-        else defuncVals ds-  return $ defs <> Seq.singleton valbind' <> ds'+  (valbind', env, dyn) <- defuncValBind valbind+  addValBind valbind'+  localEnv env $+    if dyn+      then isGlobal (valBindName valbind') $ defuncVals ds+      else defuncVals ds  {-# NOINLINE transformProg #-} @@ -1301,5 +1303,5 @@ -- resulting list of declarations. transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] transformProg decs = modifyNameSource $ \namesrc ->-  let (decs', namesrc', liftedDecs) = runDefM namesrc $ defuncVals decs-   in (toList $ liftedDecs <> decs', namesrc')+  let ((), namesrc', decs') = runDefM namesrc $ defuncVals decs+   in (decs', namesrc')

@@ -0,0 +1,2126 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Futhark.Internalise.Exps (transformProg) where++import Control.Monad.Reader+import Data.List (find, intercalate, intersperse, transpose)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Futhark.IR.SOACS as I hiding (stmPattern)+import Futhark.Internalise.AccurateSizes+import Futhark.Internalise.Bindings+import Futhark.Internalise.Lambdas+import Futhark.Internalise.Monad as I+import Futhark.Internalise.TypesValues+import Futhark.Transform.Rename as I+import Futhark.Util (splitAt3)+import Futhark.Util.Pretty (prettyOneLine)+import Language.Futhark as E hiding (TypeArg)++-- | Convert a program in source Futhark to a program in the Futhark+-- core language.+transformProg :: MonadFreshNames m => Bool -> [E.ValBind] -> m (I.Prog SOACS)+transformProg always_safe vbinds = do+  (consts, funs) <-+    runInternaliseM always_safe (internaliseValBinds vbinds)+  I.renameProg $ I.Prog consts funs++internaliseAttr :: E.AttrInfo -> Attr+internaliseAttr (E.AttrAtom v) = I.AttrAtom v+internaliseAttr (E.AttrComp f attrs) = I.AttrComp f $ map internaliseAttr attrs++internaliseAttrs :: [E.AttrInfo] -> Attrs+internaliseAttrs = mconcat . map (oneAttr . internaliseAttr)++internaliseValBinds :: [E.ValBind] -> InternaliseM ()+internaliseValBinds = mapM_ internaliseValBind++internaliseFunName :: VName -> Name+internaliseFunName = nameFromString . pretty++internaliseValBind :: E.ValBind -> InternaliseM ()+internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ attrs loc) = do+  localConstsScope $+    bindingFParams tparams params $ \shapeparams params' -> do+      let shapenames = map I.paramName shapeparams++      msg <- case retdecl of+        Just dt ->+          errorMsg+            . ("Function return value does not match shape of type " :)+            <$> typeExpForError dt+        Nothing -> return $ errorMsg ["Function return value does not match shape of declared return type."]++      (body', rettype') <- buildBody $ do+        body_res <- internaliseExp (baseString fname <> "_res") body+        rettype_bad <-+          internaliseReturnType rettype =<< mapM subExpType body_res+        let rettype' = zeroExts rettype_bad+        body_res' <-+          ensureResultExtShape msg loc (map I.fromDecl rettype') body_res+        pure (body_res', rettype')++      let all_params = shapeparams ++ concat params'++      let fd =+            I.FunDef+              Nothing+              (internaliseAttrs attrs)+              (internaliseFunName fname)+              rettype'+              all_params+              body'++      if null params'+        then bindConstant fname fd+        else+          bindFunction+            fname+            fd+            ( shapenames,+              map declTypeOf $ concat params',+              all_params,+              applyRetType rettype' all_params+            )++  case entry of+    Just (Info entry') -> generateEntryPoint entry' fb+    Nothing -> return ()+  where+    zeroExts ts = generaliseExtTypes ts ts++generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM ()+generateEntryPoint (E.EntryPoint e_paramts e_rettype) vb = localConstsScope $ do+  let (E.ValBind _ ofname _ (Info (rettype, _)) tparams params _ _ attrs loc) = vb+  bindingFParams tparams params $ \shapeparams params' -> do+    entry_rettype <- internaliseEntryReturnType rettype+    let entry' = entryPoint (baseName ofname) (zip e_paramts params') (e_rettype, entry_rettype)+        args = map (I.Var . I.paramName) $ concat params'++    entry_body <- buildBody_ $ do+      -- Special case the (rare) situation where the entry point is+      -- not a function.+      maybe_const <- lookupConst ofname+      vals <- case maybe_const of+        Just ses ->+          return ses+        Nothing ->+          fst <$> funcall "entry_result" (E.qualName ofname) args loc+      ctx <-+        extractShapeContext (concat entry_rettype)+          <$> mapM (fmap I.arrayDims . subExpType) vals+      pure $ ctx ++ vals++    addFunDef $+      I.FunDef+        (Just entry')+        (internaliseAttrs attrs)+        ("entry_" <> baseName ofname)+        (concat entry_rettype)+        (shapeparams ++ concat params')+        entry_body++entryPoint ::+  Name ->+  [(E.EntryType, [I.FParam])] ->+  ( E.EntryType,+    [[I.TypeBase ExtShape Uniqueness]]+  ) ->+  I.EntryPoint+entryPoint name params (eret, crets) =+  ( name,+    concatMap (entryPointType . preParam) params,+    case ( isTupleRecord $ entryType eret,+           entryAscribed eret+         ) of+      (Just ts, Just (E.TETuple e_ts _)) ->+        concatMap entryPointType $+          zip (zipWith E.EntryType ts (map Just e_ts)) crets+      (Just ts, Nothing) ->+        concatMap entryPointType $+          zip (map (`E.EntryType` Nothing) ts) crets+      _ ->+        entryPointType (eret, concat crets)+  )+  where+    preParam (e_t, ps) = (e_t, staticShapes $ map I.paramDeclType ps)++    entryPointType (t, ts)+      | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t =+        [I.TypeUnsigned]+      | E.Array _ _ (E.Prim E.Unsigned {}) _ <- E.entryType t =+        [I.TypeUnsigned]+      | E.Scalar E.Prim {} <- E.entryType t =+        [I.TypeDirect]+      | E.Array _ _ E.Prim {} _ <- E.entryType t =+        [I.TypeDirect]+      | otherwise =+        [I.TypeOpaque desc $ length ts]+      where+        desc = maybe (prettyOneLine t') typeExpOpaqueName $ E.entryAscribed t+        t' = noSizes (E.entryType t) `E.setUniqueness` Nonunique+    typeExpOpaqueName (TEApply te TypeArgExpDim {} _) =+      typeExpOpaqueName te+    typeExpOpaqueName (TEArray te _ _) =+      let (d, te') = withoutDims te+       in "arr_" ++ typeExpOpaqueName te'+            ++ "_"+            ++ show (1 + d)+            ++ "d"+    typeExpOpaqueName te = prettyOneLine te++    withoutDims (TEArray te _ _) =+      let (d, te') = withoutDims te+       in (d + 1, te')+    withoutDims te = (0 :: Int, te)++internaliseBody :: String -> E.Exp -> InternaliseM Body+internaliseBody desc e =+  buildBody_ $ internaliseExp (desc <> "_res") e++bodyFromStms ::+  InternaliseM (Result, a) ->+  InternaliseM (Body, a)+bodyFromStms m = do+  ((res, a), stms) <- collectStms m+  (,a) <$> mkBodyM stms res++internaliseAppExp :: String -> E.AppExp -> InternaliseM [I.SubExp]+internaliseAppExp desc (E.Index e idxs loc) = do+  vs <- internaliseExpToVars "indexed" e+  dims <- case vs of+    [] -> return [] -- Will this happen?+    v : _ -> I.arrayDims <$> lookupType v+  (idxs', cs) <- internaliseSlice loc dims idxs+  let index v = do+        v_t <- lookupType v+        return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'+  certifying cs $ letSubExps desc =<< mapM index vs+internaliseAppExp desc (E.Range start maybe_second end loc) = do+  start' <- internaliseExp1 "range_start" start+  end' <- internaliseExp1 "range_end" $ case end of+    DownToExclusive e -> e+    ToInclusive e -> e+    UpToExclusive e -> e+  maybe_second' <-+    traverse (internaliseExp1 "range_second") maybe_second++  -- Construct an error message in case the range is invalid.+  let conv = case E.typeOf start of+        E.Scalar (E.Prim (E.Unsigned _)) -> asIntZ Int64+        _ -> asIntS Int64+  start'_i64 <- conv start'+  end'_i64 <- conv end'+  maybe_second'_i64 <- traverse conv maybe_second'+  let errmsg =+        errorMsg $+          ["Range "]+            ++ [ErrorInt64 start'_i64]+            ++ ( case maybe_second'_i64 of+                   Nothing -> []+                   Just second_i64 -> ["..", ErrorInt64 second_i64]+               )+            ++ ( case end of+                   DownToExclusive {} -> ["..>"]+                   ToInclusive {} -> ["..."]+                   UpToExclusive {} -> ["..<"]+               )+            ++ [ErrorInt64 end'_i64, " is invalid."]++  (it, le_op, lt_op) <-+    case E.typeOf start of+      E.Scalar (E.Prim (E.Signed it)) -> return (it, CmpSle it, CmpSlt it)+      E.Scalar (E.Prim (E.Unsigned it)) -> return (it, CmpUle it, CmpUlt it)+      start_t -> error $ "Start value in range has type " ++ pretty start_t++  let one = intConst it 1+      negone = intConst it (-1)+      default_step = case end of+        DownToExclusive {} -> negone+        ToInclusive {} -> one+        UpToExclusive {} -> one++  (step, step_zero) <- case maybe_second' of+    Just second' -> do+      subtracted_step <-+        letSubExp "subtracted_step" $+          I.BasicOp $ I.BinOp (I.Sub it I.OverflowWrap) second' start'+      step_zero <- letSubExp "step_zero" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) start' second'+      return (subtracted_step, step_zero)+    Nothing ->+      return (default_step, constant False)++  step_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum it) step+  step_sign_i64 <- asIntS Int64 step_sign++  bounds_invalid_downwards <-+    letSubExp "bounds_invalid_downwards" $+      I.BasicOp $ I.CmpOp le_op start' end'+  bounds_invalid_upwards <-+    letSubExp "bounds_invalid_upwards" $+      I.BasicOp $ I.CmpOp lt_op end' start'++  (distance, step_wrong_dir, bounds_invalid) <- case end of+    DownToExclusive {} -> do+      step_wrong_dir <-+        letSubExp "step_wrong_dir" $+          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign one+      distance <-+        letSubExp "distance" $+          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end'+      distance_i64 <- asIntS Int64 distance+      return (distance_i64, step_wrong_dir, bounds_invalid_downwards)+    UpToExclusive {} -> do+      step_wrong_dir <-+        letSubExp "step_wrong_dir" $+          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone+      distance <- letSubExp "distance" $ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start'+      distance_i64 <- asIntS Int64 distance+      return (distance_i64, step_wrong_dir, bounds_invalid_upwards)+    ToInclusive {} -> do+      downwards <-+        letSubExp "downwards" $+          I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone+      distance_downwards_exclusive <-+        letSubExp "distance_downwards_exclusive" $+          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end'+      distance_upwards_exclusive <-+        letSubExp "distance_upwards_exclusive" $+          I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start'++      bounds_invalid <-+        letSubExp "bounds_invalid" $+          I.If+            downwards+            (resultBody [bounds_invalid_downwards])+            (resultBody [bounds_invalid_upwards])+            $ ifCommon [I.Prim I.Bool]+      distance_exclusive <-+        letSubExp "distance_exclusive" $+          I.If+            downwards+            (resultBody [distance_downwards_exclusive])+            (resultBody [distance_upwards_exclusive])+            $ ifCommon [I.Prim $ IntType it]+      distance_exclusive_i64 <- asIntS Int64 distance_exclusive+      distance <-+        letSubExp "distance" $+          I.BasicOp $+            I.BinOp+              (Add Int64 I.OverflowWrap)+              distance_exclusive_i64+              (intConst Int64 1)+      return (distance, constant False, bounds_invalid)++  step_invalid <-+    letSubExp "step_invalid" $+      I.BasicOp $ I.BinOp I.LogOr step_wrong_dir step_zero++  invalid <-+    letSubExp "range_invalid" $+      I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid+  valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid+  cs <- assert "range_valid_c" valid errmsg loc++  step_i64 <- asIntS Int64 step+  pos_step <-+    letSubExp "pos_step" $+      I.BasicOp $ I.BinOp (Mul Int64 I.OverflowWrap) step_i64 step_sign_i64++  num_elems <-+    certifying cs $+      letSubExp "num_elems" $+        I.BasicOp $ I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step++  se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)+  return [se]+internaliseAppExp desc (E.Coerce e (TypeDecl dt (Info et)) loc) = do+  ses <- internaliseExp desc e+  ts <- internaliseReturnType et =<< mapM subExpType ses+  dt' <- typeExpForError dt+  forM (zip ses ts) $ \(e', t') -> do+    dims <- arrayDims <$> subExpType e'+    let parts =+          ["Value of (core language) shape ("]+            ++ intersperse ", " (map ErrorInt64 dims)+            ++ [") cannot match shape of type `"]+            ++ dt'+            ++ ["`."]+    ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e'+internaliseAppExp desc e@E.Apply {} = do+  (qfname, args) <- findFuncall e++  -- Argument evaluation is outermost-in so that any existential sizes+  -- created by function applications can be brought into scope.+  let fname = nameFromString $ pretty $ baseName $ qualLeaf qfname+      loc = srclocOf e+      arg_desc = nameToString fname ++ "_arg"++  -- Some functions are magical (overloaded) and we handle that here.+  case () of+    -- Overloaded functions never take array arguments (except+    -- equality, but those cannot be existential), so we can safely+    -- ignore the existential dimensions.+    ()+      | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->+        internalise desc+      | baseTag (qualLeaf qfname) <= maxIntrinsicTag,+        Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do+        let tag ses = [(se, I.Observe) | se <- ses]+        args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)+        let args'' = concatMap tag args'+        letTupExp' desc $+          I.Apply+            fname+            args''+            [I.Prim rettype]+            (Safe, loc, [])+      | otherwise -> do+        args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)+        fst <$> funcall desc qfname args' loc+internaliseAppExp desc (E.LetPat sizes pat e body _) =+  internalisePat desc sizes pat e body (internaliseExp desc)+internaliseAppExp _ (E.LetFun ofname _ _ _) =+  error $ "Unexpected LetFun " ++ pretty ofname+internaliseAppExp desc (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do+  ses <- internaliseExp "loop_init" mergeexp+  ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <-+    collectStms $ handleForm ses form++  addStms initstms+  mergeinit_ts' <- mapM subExpType mergeinit'++  ctxinit <- argShapes (map I.paramName shapepat) mergepat' mergeinit_ts'++  let ctxmerge = zip shapepat ctxinit+      valmerge = zip mergepat' mergeinit'+      dropCond = case form of+        E.While {} -> drop 1+        _ -> id++  -- Ensure that the result of the loop matches the shapes of the+  -- merge parameters.  XXX: Ideally they should already match (by+  -- the source language type rules), but some of our+  -- transformations (esp. defunctionalisation) strips out some size+  -- information.  For a type-correct source program, these reshapes+  -- should simplify away.+  let merge = ctxmerge ++ valmerge+      merge_ts = map (I.paramType . fst) merge+  loopbody'' <-+    localScope (scopeOfFParams $ map fst merge) . inScopeOf form' . buildBody_ $+      ensureArgShapes+        "shape of loop result does not match shapes in loop parameter"+        loc+        (map (I.paramName . fst) ctxmerge)+        merge_ts+        =<< bodyBind loopbody'++  attrs <- asks envAttrs+  map I.Var . dropCond+    <$> attributing+      attrs+      (letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody''))+  where+    sparams' = map (`TypeParamDim` mempty) sparams++    forLoop mergepat' shapepat mergeinit form' =+      bodyFromStms $+        inScopeOf form' $ do+          ses <- internaliseExp "loopres" loopbody+          sets <- mapM subExpType ses+          shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets+          return+            ( shapeargs ++ ses,+              ( form',+                shapepat,+                mergepat',+                mergeinit+              )+            )++    handleForm mergeinit (E.ForIn x arr) = do+      arr' <- internaliseExpToVars "for_in_arr" arr+      arr_ts <- mapM lookupType arr'+      let w = arraysSize 0 arr_ts++      i <- newVName "i"++      ts <- mapM subExpType mergeinit+      bindingLoopParams sparams' mergepat ts $+        \shapepat mergepat' ->+          bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do+            let loopvars = zip x_params arr'+            forLoop mergepat' shapepat mergeinit $+              I.ForLoop i Int64 w loopvars+    handleForm mergeinit (E.For i num_iterations) = do+      num_iterations' <- internaliseExp1 "upper_bound" num_iterations+      num_iterations_t <- I.subExpType num_iterations'+      it <- case num_iterations_t of+        I.Prim (IntType it) -> return it+        _ -> error "internaliseExp DoLoop: invalid type"++      ts <- mapM subExpType mergeinit+      bindingLoopParams sparams' mergepat ts $+        \shapepat mergepat' ->+          forLoop mergepat' shapepat mergeinit $+            I.ForLoop (E.identName i) it num_iterations' []+    handleForm mergeinit (E.While cond) = do+      ts <- mapM subExpType mergeinit+      bindingLoopParams sparams' mergepat ts $ \shapepat mergepat' -> do+        mergeinit_ts <- mapM subExpType mergeinit+        -- We need to insert 'cond' twice - once for the initial+        -- condition (do we enter the loop at all?), and once with the+        -- result values of the loop (do we continue into the next+        -- iteration?).  This is safe, as the type rules for the+        -- external language guarantees that 'cond' does not consume+        -- anything.+        shapeinit <- argShapes (map I.paramName shapepat) mergepat' mergeinit_ts++        (loop_initial_cond, init_loop_cond_bnds) <- collectStms $ do+          forM_ (zip shapepat shapeinit) $ \(p, se) ->+            letBindNames [paramName p] $ BasicOp $ SubExp se+          forM_ (zip mergepat' mergeinit) $ \(p, se) ->+            unless (se == I.Var (paramName p)) $+              letBindNames [paramName p] $+                BasicOp $+                  case se of+                    I.Var v+                      | not $ primType $ paramType p ->+                        Reshape (map DimCoercion $ arrayDims $ paramType p) v+                    _ -> SubExp se+          internaliseExp1 "loop_cond" cond++        addStms init_loop_cond_bnds++        bodyFromStms $ do+          ses <- internaliseExp "loopres" loopbody+          sets <- mapM subExpType ses+          loop_while <- newParam "loop_while" $ I.Prim I.Bool+          shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets++          -- Careful not to clobber anything.+          loop_end_cond_body <- renameBody <=< buildBody_ $ do+            forM_ (zip shapepat shapeargs) $ \(p, se) ->+              unless (se == I.Var (paramName p)) $+                letBindNames [paramName p] $ BasicOp $ SubExp se+            forM_ (zip mergepat' ses) $ \(p, se) ->+              unless (se == I.Var (paramName p)) $+                letBindNames [paramName p] $+                  BasicOp $+                    case se of+                      I.Var v+                        | not $ primType $ paramType p ->+                          Reshape (map DimCoercion $ arrayDims $ paramType p) v+                      _ -> SubExp se+            internaliseExp "loop_cond" cond+          loop_end_cond <- bodyBind loop_end_cond_body++          return+            ( shapeargs ++ loop_end_cond ++ ses,+              ( I.WhileLoop $ I.paramName loop_while,+                shapepat,+                loop_while : mergepat',+                loop_initial_cond : mergeinit+              )+            )+internaliseAppExp desc (E.LetWith name src idxs ve body loc) = do+  let pat = E.Id (E.identName name) (E.identType name) loc+      src_t = E.fromStruct <$> E.identType src+      e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc+  internaliseExp desc $+    E.AppExp+      (E.LetPat [] pat e body loc)+      (Info (AppRes (E.typeOf body) mempty))+internaliseAppExp desc (E.Match e cs _) = do+  ses <- internaliseExp (desc ++ "_scrutinee") e+  case NE.uncons cs of+    (CasePat pCase eCase _, Nothing) -> do+      (_, pertinent) <- generateCond pCase ses+      internalisePat' [] pCase pertinent eCase (internaliseExp desc)+    (c, Just cs') -> do+      let CasePat pLast eLast _ = NE.last cs'+      bFalse <- do+        (_, pertinent) <- generateCond pLast ses+        eLast' <- internalisePat' [] pLast pertinent eLast (internaliseBody desc)+        foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $+          reverse $ NE.init cs'+      letTupExp' desc =<< generateCaseIf ses c bFalse+internaliseAppExp desc (E.If ce te fe _) =+  letTupExp' desc+    =<< eIf+      (BasicOp . SubExp <$> internaliseExp1 "cond" ce)+      (internaliseBody (desc <> "_t") te)+      (internaliseBody (desc <> "_f") fe)+internaliseAppExp _ e@E.BinOp {} =+  error $ "internaliseAppExp: Unexpected BinOp " ++ pretty e++internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp]+internaliseExp desc (E.Parens e _) =+  internaliseExp desc e+internaliseExp desc (E.QualParens _ e _) =+  internaliseExp desc e+internaliseExp desc (E.StringLit vs _) =+  fmap pure $+    letSubExp desc $+      I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8+internaliseExp _ (E.Var (E.QualName _ name) _ _) = do+  subst <- lookupSubst name+  case subst of+    Just substs -> return substs+    Nothing -> pure [I.Var name]+internaliseExp desc (E.AppExp e (Info appres)) = do+  ses <- internaliseAppExp desc e+  bindExtSizes appres ses+  pure ses++-- XXX: we map empty records and tuples to units, because otherwise+-- arrays of unit will lose their sizes.+internaliseExp _ (E.TupLit [] _) =+  return [constant UnitValue]+internaliseExp _ (E.RecordLit [] _) =+  return [constant UnitValue]+internaliseExp desc (E.TupLit es _) = concat <$> mapM (internaliseExp desc) es+internaliseExp desc (E.RecordLit orig_fields _) =+  concatMap snd . sortFields . M.unions <$> mapM internaliseField orig_fields+  where+    internaliseField (E.RecordFieldExplicit name e _) =+      M.singleton name <$> internaliseExp desc e+    internaliseField (E.RecordFieldImplicit name t loc) =+      internaliseField $+        E.RecordFieldExplicit+          (baseName name)+          (E.Var (E.qualName name) t loc)+          loc+internaliseExp desc (E.ArrayLit es (Info arr_t) loc)+  -- If this is a multidimensional array literal of primitives, we+  -- treat it specially by flattening it out followed by a reshape.+  -- This cuts down on the amount of statements that are produced, and+  -- thus allows us to efficiently handle huge array literals - a+  -- corner case, but an important one.+  | Just ((eshape, e') : es') <- mapM isArrayLiteral es,+    not $ null eshape,+    all ((eshape ==) . fst) es',+    Just basetype <- E.peelArray (length eshape) arr_t = do+    let flat_lit = E.ArrayLit (e' ++ concatMap snd es') (Info basetype) loc+        new_shape = length es : eshape+    flat_arrs <- internaliseExpToVars "flat_literal" flat_lit+    forM flat_arrs $ \flat_arr -> do+      flat_arr_t <- lookupType flat_arr+      let new_shape' =+            reshapeOuter+              (map (DimNew . intConst Int64 . toInteger) new_shape)+              1+              $ I.arrayShape flat_arr_t+      letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr+  | otherwise = do+    es' <- mapM (internaliseExp "arr_elem") es+    arr_t_ext <- internaliseType $ E.toStruct arr_t++    rowtypes <-+      case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of+        Just ts -> pure ts+        Nothing ->+          -- XXX: the monomorphiser may create single-element array+          -- literals with an unknown row type.  In those cases we+          -- need to look at the types of the actual elements.+          -- Fixing this in the monomorphiser is a lot more tricky+          -- than just working around it here.+          case es' of+            [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t+            e' : _ -> mapM subExpType e'++    let arraylit ks rt = do+          ks' <-+            mapM+              ( ensureShape+                  "shape of element differs from shape of first element"+                  loc+                  rt+                  "elem_reshaped"+              )+              ks+          return $ I.BasicOp $ I.ArrayLit ks' rt++    letSubExps desc+      =<< if null es'+        then mapM (arraylit []) rowtypes+        else zipWithM arraylit (transpose es') rowtypes+  where+    isArrayLiteral :: E.Exp -> Maybe ([Int], [E.Exp])+    isArrayLiteral (E.ArrayLit inner_es _ _) = do+      (eshape, e) : inner_es' <- mapM isArrayLiteral inner_es+      guard $ all ((eshape ==) . fst) inner_es'+      return (length inner_es : eshape, e ++ concatMap snd inner_es')+    isArrayLiteral e =+      Just ([], [e])+internaliseExp desc (E.Ascript e _ _) =+  internaliseExp desc e+internaliseExp desc (E.Negate e _) = do+  e' <- internaliseExp1 "negate_arg" e+  et <- subExpType e'+  case et of+    I.Prim (I.IntType t) ->+      letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e'+    I.Prim (I.FloatType t) ->+      letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'+    _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"+internaliseExp desc (E.Update src slice ve loc) = do+  ves <- internaliseExp "lw_val" ve+  srcs <- internaliseExpToVars "src" src+  dims <- case srcs of+    [] -> return [] -- Will this happen?+    v : _ -> I.arrayDims <$> lookupType v+  (idxs', cs) <- internaliseSlice loc dims slice++  let comb sname ve' = do+        sname_t <- lookupType sname+        let full_slice = fullSlice sname_t idxs'+            rowtype = sname_t `setArrayDims` sliceDims full_slice+        ve'' <-+          ensureShape+            "shape of value does not match shape of source array"+            loc+            rowtype+            "lw_val_correct_shape"+            ve'+        letInPlace desc sname full_slice $ BasicOp $ SubExp ve''+  certifying cs $ map I.Var <$> zipWithM comb srcs ves+internaliseExp desc (E.RecordUpdate src fields ve _ _) = do+  src' <- internaliseExp desc src+  ve' <- internaliseExp desc ve+  replace (E.typeOf src `setAliases` ()) fields ve' src'+  where+    replace (E.Scalar (E.Record m)) (f : fs) ve' src'+      | Just t <- M.lookup f m = do+        i <-+          fmap sum $+            mapM (internalisedTypeSize . snd) $+              takeWhile ((/= f) . fst) $ sortFields m+        k <- internalisedTypeSize t+        let (bef, to_update, aft) = splitAt3 i k src'+        src'' <- replace t fs ve' to_update+        return $ bef ++ src'' ++ aft+    replace _ _ ve' _ = return ve'+internaliseExp desc (E.Attr attr e _) =+  local f $ internaliseExp desc e+  where+    attrs = oneAttr $ internaliseAttr attr+    f env+      | "unsafe" `inAttrs` attrs,+        not $ envSafe env =+        env {envDoBoundsChecks = False}+      | otherwise =+        env {envAttrs = envAttrs env <> attrs}+internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do+  e1' <- internaliseExp1 "assert_cond" e1+  c <- assert "assert_c" e1' (errorMsg [ErrorString $ "Assertion is false: " <> check]) loc+  -- Make sure there are some bindings to certify.+  certifying c $ mapM rebind =<< internaliseExp desc e2+  where+    rebind v = do+      v' <- newVName "assert_res"+      letBindNames [v'] $ I.BasicOp $ I.SubExp v+      return $ I.Var v'+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 Int64 0+  ts' <- instantiateShapes noExt $ map fromDecl ts++  case M.lookup c constr_map of+    Just (i, js) ->+      (intConst Int8 (toInteger i) :) <$> clauses 0 ts' (zip js es')+    Nothing ->+      error "internaliseExp Constr: missing constructor"+  where+    clauses j (t : ts) js_to_es+      | Just e <- j `lookup` js_to_es =+        (e :) <$> clauses (j + 1) ts js_to_es+      | otherwise = do+        blank <- letSubExp "zero" =<< eBlank t+        (blank :) <$> clauses (j + 1) ts js_to_es+    clauses _ [] _ =+      return []+internaliseExp _ (E.Constr _ _ (Info t) loc) =+  error $ "internaliseExp: constructor with type " ++ pretty t ++ " at " ++ locStr loc+-- The "interesting" cases are over, now it's mostly boilerplate.++internaliseExp _ (E.Literal v _) =+  return [I.Constant $ internalisePrimValue v]+internaliseExp _ (E.IntLit v (Info t) _) =+  case t of+    E.Scalar (E.Prim (E.Signed it)) ->+      return [I.Constant $ I.IntValue $ intValue it v]+    E.Scalar (E.Prim (E.Unsigned it)) ->+      return [I.Constant $ I.IntValue $ intValue it v]+    E.Scalar (E.Prim (E.FloatType ft)) ->+      return [I.Constant $ I.FloatValue $ floatValue ft v]+    _ -> error $ "internaliseExp: nonsensical type for integer literal: " ++ pretty t+internaliseExp _ (E.FloatLit v (Info t) _) =+  case t of+    E.Scalar (E.Prim (E.FloatType ft)) ->+      return [I.Constant $ I.FloatValue $ floatValue ft v]+    _ -> error $ "internaliseExp: nonsensical type for float literal: " ++ pretty t+-- Builtin operators are handled specially because they are+-- overloaded.+internaliseExp desc (E.Project k e (Info rt) _) = do+  n <- internalisedTypeSize $ rt `setAliases` ()+  i' <- fmap sum $+    mapM internalisedTypeSize $+      case E.typeOf e `setAliases` () of+        E.Scalar (Record fs) ->+          map snd $ takeWhile ((/= k) . fst) $ sortFields fs+        t -> [t]+  take n . drop i' <$> internaliseExp desc e+internaliseExp _ e@E.Lambda {} =+  error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e)+internaliseExp _ e@E.OpSection {} =+  error $ "internaliseExp: Unexpected operator section at " ++ locStr (srclocOf e)+internaliseExp _ e@E.OpSectionLeft {} =+  error $ "internaliseExp: Unexpected left operator section at " ++ locStr (srclocOf e)+internaliseExp _ e@E.OpSectionRight {} =+  error $ "internaliseExp: Unexpected right operator section at " ++ locStr (srclocOf e)+internaliseExp _ e@E.ProjectSection {} =+  error $ "internaliseExp: Unexpected projection section at " ++ locStr (srclocOf e)+internaliseExp _ e@E.IndexSection {} =+  error $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e)++internaliseArg :: String -> (E.Exp, Maybe VName) -> InternaliseM [SubExp]+internaliseArg desc (arg, argdim) = do+  arg' <- internaliseExp desc arg+  case (arg', argdim) of+    ([se], Just d) -> letBindNames [d] $ BasicOp $ SubExp se+    _ -> return ()+  return arg'++subExpPrimType :: I.SubExp -> InternaliseM I.PrimType+subExpPrimType = fmap I.elemType . subExpType++generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp])+generateCond orig_p orig_ses = do+  (cmps, pertinent, _) <- compares orig_p orig_ses+  cmp <- letSubExp "matches" =<< eAll cmps+  return (cmp, pertinent)+  where+    -- Literals are always primitive values.+    compares (E.PatternLit l t _) (se : ses) = do+      e' <- case l of+        PatLitPrim v -> pure $ constant $ internalisePrimValue v+        PatLitInt x -> internaliseExp1 "constant" $ E.IntLit x t mempty+        PatLitFloat x -> internaliseExp1 "constant" $ E.FloatLit x t mempty+      t' <- subExpPrimType se+      cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se+      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+      case M.lookup c m of+        Just (i, payload_is) -> do+          let i' = intConst Int8 $ toInteger i+          let (payload_ses, ses') = splitAt (length payload_ts) ses+          cmp <- letSubExp "match_constr" $ I.BasicOp $ I.CmpOp (I.CmpEq int8) i' se+          (cmps, pertinent, _) <- comparesMany pats $ map (payload_ses !!) payload_is+          return (cmp : cmps, pertinent, ses')+        Nothing ->+          error "generateCond: missing constructor"+    compares (E.PatternConstr _ (Info t) _ _) _ =+      error $ "generateCond: PatternConstr has nonsensical type: " ++ pretty t+    compares (E.Id _ t loc) ses =+      compares (E.Wildcard t loc) ses+    compares (E.Wildcard (Info t) _) ses = do+      n <- internalisedTypeSize $ E.toStruct t+      let (id_ses, rest_ses) = splitAt n ses+      return ([], id_ses, rest_ses)+    compares (E.PatternParens pat _) ses =+      compares pat ses+    -- XXX: treat empty tuples and records as bool.+    compares (E.TuplePattern [] loc) ses =+      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses+    compares (E.RecordPattern [] loc) ses =+      compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses+    compares (E.TuplePattern pats _) ses =+      comparesMany pats ses+    compares (E.RecordPattern fs _) ses =+      comparesMany (map snd $ E.sortFields $ M.fromList fs) ses+    compares (E.PatternAscription pat _ _) ses =+      compares pat ses+    compares pat [] =+      error $ "generateCond: No values left for pattern " ++ pretty pat++    comparesMany [] ses = return ([], [], ses)+    comparesMany (pat : pats) ses = do+      (cmps1, pertinent1, ses') <- compares pat ses+      (cmps2, pertinent2, ses'') <- comparesMany pats ses'+      return+        ( cmps1 <> cmps2,+          pertinent1 <> pertinent2,+          ses''+        )++generateCaseIf :: [I.SubExp] -> Case -> I.Body -> InternaliseM I.Exp+generateCaseIf ses (CasePat p eCase _) bFail = do+  (cond, pertinent) <- generateCond p ses+  eCase' <- internalisePat' [] p pertinent eCase (internaliseBody "case")+  eIf (eSubExp cond) (return eCase') (return bFail)++internalisePat ::+  String ->+  [E.SizeBinder VName] ->+  E.Pattern ->+  E.Exp ->+  E.Exp ->+  (E.Exp -> InternaliseM a) ->+  InternaliseM a+internalisePat desc sizes p e body m = do+  ses <- internaliseExp desc' e+  internalisePat' sizes p ses body m+  where+    desc' = case S.toList $ E.patternIdents p of+      [v] -> baseString $ E.identName v+      _ -> desc++internalisePat' ::+  [E.SizeBinder VName] ->+  E.Pattern ->+  [I.SubExp] ->+  E.Exp ->+  (E.Exp -> InternaliseM a) ->+  InternaliseM a+internalisePat' sizes p ses body m = do+  ses_ts <- mapM subExpType ses+  stmPattern p ses_ts $ \pat_names -> do+    bindExtSizes (AppRes (E.patternType p) (map E.sizeName sizes)) ses+    forM_ (zip pat_names ses) $ \(v, se) ->+      letBindNames [v] $ I.BasicOp $ I.SubExp se+    m body++internaliseSlice ::+  SrcLoc ->+  [SubExp] ->+  [E.DimIndex] ->+  InternaliseM ([I.DimIndex SubExp], Certificates)+internaliseSlice loc dims idxs = do+  (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs+  ok <- letSubExp "index_ok" =<< eAll oks+  let msg =+        errorMsg $+          ["Index ["] ++ intercalate [", "] parts+            ++ ["] out of bounds for array of shape ["]+            ++ intersperse "][" (map ErrorInt64 $ take (length idxs) dims)+            ++ ["]."]+  c <- assert "index_certs" ok msg loc+  return (idxs', c)++internaliseDimIndex ::+  SubExp ->+  E.DimIndex ->+  InternaliseM (I.DimIndex SubExp, SubExp, [ErrorMsgPart SubExp])+internaliseDimIndex w (E.DimFix i) = do+  (i', _) <- internaliseDimExp "i" i+  let lowerBound =+        I.BasicOp $+          I.CmpOp (I.CmpSle I.Int64) (I.constant (0 :: I.Int64)) i'+      upperBound =+        I.BasicOp $+          I.CmpOp (I.CmpSlt I.Int64) i' w+  ok <- letSubExp "bounds_check" =<< eBinOp I.LogAnd (pure lowerBound) (pure upperBound)+  return (I.DimFix i', ok, [ErrorInt64 i'])++-- Special-case an important common case that otherwise leads to horrible code.+internaliseDimIndex+  w+  ( E.DimSlice+      Nothing+      Nothing+      (Just (E.Negate (E.IntLit 1 _ _) _))+    ) = do+    w_minus_1 <-+      letSubExp "w_minus_1" $+        BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one+    return+      ( I.DimSlice w_minus_1 w $ intConst Int64 (-1),+        constant True,+        mempty+      )+    where+      one = constant (1 :: Int64)+internaliseDimIndex w (E.DimSlice i j s) = do+  s' <- maybe (return one) (fmap fst . internaliseDimExp "s") s+  s_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum Int64) s'+  backwards <- letSubExp "backwards" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) s_sign negone+  w_minus_1 <- letSubExp "w_minus_1" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one+  let i_def =+        letSubExp "i_def" $+          I.If+            backwards+            (resultBody [w_minus_1])+            (resultBody [zero])+            $ ifCommon [I.Prim int64]+      j_def =+        letSubExp "j_def" $+          I.If+            backwards+            (resultBody [negone])+            (resultBody [w])+            $ ifCommon [I.Prim int64]+  i' <- maybe i_def (fmap fst . internaliseDimExp "i") i+  j' <- maybe j_def (fmap fst . internaliseDimExp "j") j+  j_m_i <- letSubExp "j_m_i" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) j' i'+  -- Something like a division-rounding-up, but accomodating negative+  -- operands.+  let divRounding x y =+        eBinOp+          (SQuot Int64 Safe)+          ( eBinOp+              (Add Int64 I.OverflowWrap)+              x+              (eBinOp (Sub Int64 I.OverflowWrap) y (eSignum $ toExp s'))+          )+          y+  n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s')++  zero_stride <- letSubExp "zero_stride" $ I.BasicOp $ I.CmpOp (CmpEq int64) s_sign zero+  nonzero_stride <- letSubExp "nonzero_stride" $ I.BasicOp $ I.UnOp Not zero_stride++  -- Bounds checks depend on whether we are slicing forwards or+  -- backwards.  If forwards, we must check '0 <= i && i <= j'.  If+  -- backwards, '-1 <= j && j <= i'.  In both cases, we check '0 <=+  -- i+n*s && i+(n-1)*s < w'.  We only check if the slice is nonempty.+  empty_slice <- letSubExp "empty_slice" $ I.BasicOp $ I.CmpOp (CmpEq int64) n zero++  m <- letSubExp "m" $ I.BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) n one+  m_t_s <- letSubExp "m_t_s" $ I.BasicOp $ I.BinOp (Mul Int64 I.OverflowWrap) m s'+  i_p_m_t_s <- letSubExp "i_p_m_t_s" $ I.BasicOp $ I.BinOp (Add Int64 I.OverflowWrap) i' m_t_s+  zero_leq_i_p_m_t_s <-+    letSubExp "zero_leq_i_p_m_t_s" $+      I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i_p_m_t_s+  i_p_m_t_s_leq_w <-+    letSubExp "i_p_m_t_s_leq_w" $+      I.BasicOp $ I.CmpOp (I.CmpSle Int64) i_p_m_t_s w+  i_p_m_t_s_lth_w <-+    letSubExp "i_p_m_t_s_leq_w" $+      I.BasicOp $ I.CmpOp (I.CmpSlt Int64) i_p_m_t_s w++  zero_lte_i <- letSubExp "zero_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i'+  i_lte_j <- letSubExp "i_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) i' j'+  forwards_ok <-+    letSubExp "forwards_ok"+      =<< eAll [zero_lte_i, zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w]++  negone_lte_j <- letSubExp "negone_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) negone j'+  j_lte_i <- letSubExp "j_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) j' i'+  backwards_ok <-+    letSubExp "backwards_ok"+      =<< eAll+        [negone_lte_j, negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w]++  slice_ok <-+    letSubExp "slice_ok" $+      I.If+        backwards+        (resultBody [backwards_ok])+        (resultBody [forwards_ok])+        $ ifCommon [I.Prim I.Bool]++  ok_or_empty <-+    letSubExp "ok_or_empty" $+      I.BasicOp $ I.BinOp I.LogOr empty_slice slice_ok++  acceptable <-+    letSubExp "slice_acceptable" $+      I.BasicOp $ I.BinOp I.LogAnd nonzero_stride ok_or_empty++  let parts = case (i, j, s) of+        (_, _, Just {}) ->+          [ maybe "" (const $ ErrorInt64 i') i,+            ":",+            maybe "" (const $ ErrorInt64 j') j,+            ":",+            ErrorInt64 s'+          ]+        (_, Just {}, _) ->+          [ maybe "" (const $ ErrorInt64 i') i,+            ":",+            ErrorInt64 j'+          ]+            ++ maybe mempty (const [":", ErrorInt64 s']) s+        (_, Nothing, Nothing) ->+          [ErrorInt64 i', ":"]+  return (I.DimSlice i' n s', acceptable, parts)+  where+    zero = constant (0 :: Int64)+    negone = constant (-1 :: Int64)+    one = constant (1 :: Int64)++internaliseScanOrReduce ::+  String ->+  String ->+  (SubExp -> I.Lambda -> [SubExp] -> [VName] -> InternaliseM (SOAC SOACS)) ->+  (E.Exp, E.Exp, E.Exp, SrcLoc) ->+  InternaliseM [SubExp]+internaliseScanOrReduce desc what f (lam, ne, arr, loc) = do+  arrs <- internaliseExpToVars (what ++ "_arr") arr+  nes <- internaliseExp (what ++ "_ne") ne+  nes' <- forM (zip nes arrs) $ \(ne', arr') -> do+    rowtype <- I.stripArray 1 <$> lookupType arr'+    ensureShape+      "Row shape of input array does not match shape of neutral element"+      loc+      rowtype+      (what ++ "_ne_right_shape")+      ne'+  nests <- mapM I.subExpType nes'+  arrts <- mapM lookupType arrs+  lam' <- internaliseFoldLambda internaliseLambda lam nests arrts+  w <- arraysSize 0 <$> mapM lookupType arrs+  letTupExp' desc . I.Op =<< f w lam' nes' arrs++internaliseHist ::+  String ->+  E.Exp ->+  E.Exp ->+  E.Exp ->+  E.Exp ->+  E.Exp ->+  E.Exp ->+  SrcLoc ->+  InternaliseM [SubExp]+internaliseHist desc rf hist op ne buckets img loc = do+  rf' <- internaliseExp1 "hist_rf" rf+  ne' <- internaliseExp "hist_ne" ne+  hist' <- internaliseExpToVars "hist_hist" hist+  buckets' <-+    letExp "hist_buckets" . BasicOp . SubExp+      =<< internaliseExp1 "hist_buckets" buckets+  img' <- internaliseExpToVars "hist_img" img++  -- reshape neutral element to have same size as the destination array+  ne_shp <- forM (zip ne' hist') $ \(n, h) -> do+    rowtype <- I.stripArray 1 <$> lookupType h+    ensureShape+      "Row shape of destination array does not match shape of neutral element"+      loc+      rowtype+      "hist_ne_right_shape"+      n+  ne_ts <- mapM I.subExpType ne_shp+  his_ts <- mapM lookupType hist'+  op' <- internaliseFoldLambda internaliseLambda op ne_ts his_ts++  -- reshape return type of bucket function to have same size as neutral element+  -- (modulo the index)+  bucket_param <- newParam "bucket_p" $ I.Prim int64+  img_params <- mapM (newParam "img_p" . rowType) =<< mapM lookupType img'+  let params = bucket_param : img_params+      rettype = I.Prim int64 : ne_ts+      body = mkBody mempty $ map (I.Var . paramName) params+  lam' <-+    mkLambda params $+      ensureResultShape+        "Row shape of value array does not match row shape of hist target"+        (srclocOf img)+        rettype+        =<< bodyBind body++  -- get sizes of histogram and image arrays+  w_hist <- arraysSize 0 <$> mapM lookupType hist'+  w_img <- arraysSize 0 <$> mapM lookupType img'++  -- Generate an assertion and reshapes to ensure that buckets' and+  -- img' are the same size.+  b_shape <- I.arrayShape <$> lookupType buckets'+  let b_w = shapeSize 0 b_shape+  cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int64) b_w w_img+  c <-+    assert+      "bucket_cert"+      cmp+      "length of index and value array does not match"+      loc+  buckets'' <-+    certifying c $+      letExp (baseString buckets') $+        I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets'++  letTupExp' desc . I.Op $+    I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] lam' $ buckets'' : img'++internaliseStreamMap ::+  String ->+  StreamOrd ->+  E.Exp ->+  E.Exp ->+  InternaliseM [SubExp]+internaliseStreamMap desc o lam arr = do+  arrs <- internaliseExpToVars "stream_input" arr+  lam' <- internaliseStreamMapLambda internaliseLambda lam $ map I.Var arrs+  w <- arraysSize 0 <$> mapM lookupType arrs+  let form = I.Parallel o Commutative (I.Lambda [] (mkBody mempty []) [])+  letTupExp' desc $ I.Op $ I.Stream w arrs form [] lam'++internaliseStreamRed ::+  String ->+  StreamOrd ->+  Commutativity ->+  E.Exp ->+  E.Exp ->+  E.Exp ->+  InternaliseM [SubExp]+internaliseStreamRed desc o comm lam0 lam arr = do+  arrs <- internaliseExpToVars "stream_input" arr+  rowts <- mapM (fmap I.rowType . lookupType) arrs+  (lam_params, lam_body) <-+    internaliseStreamLambda internaliseLambda lam rowts+  let (chunk_param, _, lam_val_params) =+        partitionChunkedFoldParameters 0 lam_params++  -- Synthesize neutral elements by applying the fold function+  -- to an empty chunk.+  letBindNames [I.paramName chunk_param] $+    I.BasicOp $ I.SubExp $ constant (0 :: Int64)+  forM_ lam_val_params $ \p ->+    letBindNames [I.paramName p] $+      I.BasicOp $+        I.Scratch (I.elemType $ I.paramType p) $+          I.arrayDims $ I.paramType p+  nes <- bodyBind =<< renameBody lam_body++  nes_ts <- mapM I.subExpType nes+  outsz <- arraysSize 0 <$> mapM lookupType arrs+  let acc_arr_tps = [I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- nes_ts]+  lam0' <- internaliseFoldLambda internaliseLambda lam0 nes_ts acc_arr_tps++  let lam0_acc_params = take (length nes) $ I.lambdaParams lam0'+  lam_acc_params <- forM lam0_acc_params $ \p -> do+    name <- newVName $ baseString $ I.paramName p+    return p {I.paramName = name}++  -- Make sure the chunk size parameter comes first.+  let lam_params' = chunk_param : lam_acc_params ++ lam_val_params++  lam' <- mkLambda lam_params' $ do+    lam_res <- bodyBind lam_body+    lam_res' <-+      ensureArgShapes+        "shape of chunk function result does not match shape of initial value"+        (srclocOf lam)+        []+        (map I.typeOf $ I.lambdaParams lam0')+        lam_res+    ensureResultShape+      "shape of result does not match shape of initial value"+      (srclocOf lam0)+      nes_ts+      =<< ( eLambda lam0' . map eSubExp $+              map (I.Var . paramName) lam_acc_params ++ lam_res'+          )++  let form = I.Parallel o comm lam0'+  w <- arraysSize 0 <$> mapM lookupType arrs+  letTupExp' desc $ I.Op $ I.Stream w arrs form nes lam'++internaliseStreamAcc ::+  String ->+  E.Exp ->+  Maybe (E.Exp, E.Exp) ->+  E.Exp ->+  E.Exp ->+  InternaliseM [SubExp]+internaliseStreamAcc desc dest op lam bs = do+  dest' <- internaliseExpToVars "scatter_dest" dest+  bs' <- internaliseExpToVars "scatter_input" bs++  acc_cert_v <- newVName "acc_cert"+  dest_ts <- mapM lookupType dest'+  let dest_w = arraysSize 0 dest_ts+      acc_t = Acc acc_cert_v (Shape [dest_w]) (map rowType dest_ts) NoUniqueness+  acc_p <- newParam "acc_p" acc_t+  withacc_lam <- mkLambda [Param acc_cert_v (I.Prim I.Unit), acc_p] $ do+    lam' <-+      internaliseMapLambda internaliseLambda lam $+        map I.Var $ paramName acc_p : bs'+    w <- arraysSize 0 <$> mapM lookupType bs'+    letTupExp' "acc_res" $ I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam')++  op' <-+    case op of+      Just (op_lam, ne) -> do+        ne' <- internaliseExp "hist_ne" ne+        ne_ts <- mapM I.subExpType ne'+        (lam_params, lam_body, lam_rettype) <-+          internaliseLambda op_lam $ ne_ts ++ ne_ts+        idxp <- newParam "idx" $ I.Prim int64+        let op_lam' = I.Lambda (idxp : lam_params) lam_body lam_rettype+        return $ Just (op_lam', ne')+      Nothing ->+        return Nothing++  destw <- arraysSize 0 <$> mapM lookupType dest'+  fmap (map I.Var) $+    letTupExp desc $ WithAcc [(Shape [destw], dest', op')] withacc_lam++internaliseExp1 :: String -> E.Exp -> InternaliseM I.SubExp+internaliseExp1 desc e = do+  vs <- internaliseExp desc e+  case vs of+    [se] -> return se+    _ -> error "Internalise.internaliseExp1: was passed not just a single subexpression"++-- | Promote to dimension type as appropriate for the original type.+-- Also return original type.+internaliseDimExp :: String -> E.Exp -> InternaliseM (I.SubExp, IntType)+internaliseDimExp s e = do+  e' <- internaliseExp1 s e+  case E.typeOf e of+    E.Scalar (E.Prim (Signed it)) -> (,it) <$> asIntS Int64 e'+    _ -> error "internaliseDimExp: bad type"++internaliseExpToVars :: String -> E.Exp -> InternaliseM [I.VName]+internaliseExpToVars desc e =+  mapM asIdent =<< internaliseExp desc e+  where+    asIdent (I.Var v) = return v+    asIdent se = letExp desc $ I.BasicOp $ I.SubExp se++internaliseOperation ::+  String ->+  E.Exp ->+  (I.VName -> InternaliseM I.BasicOp) ->+  InternaliseM [I.SubExp]+internaliseOperation s e op = do+  vs <- internaliseExpToVars s e+  letSubExps s =<< mapM (fmap I.BasicOp . op) vs++certifyingNonzero ::+  SrcLoc ->+  IntType ->+  SubExp ->+  InternaliseM a ->+  InternaliseM a+certifyingNonzero loc t x m = do+  zero <-+    letSubExp "zero" $+      I.BasicOp $+        CmpOp (CmpEq (IntType t)) x (intConst t 0)+  nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero+  c <- assert "nonzero_cert" nonzero "division by zero" loc+  certifying c m++certifyingNonnegative ::+  SrcLoc ->+  IntType ->+  SubExp ->+  InternaliseM a ->+  InternaliseM a+certifyingNonnegative loc t x m = do+  nonnegative <-+    letSubExp "nonnegative" $+      I.BasicOp $+        CmpOp (CmpSle t) (intConst t 0) x+  c <- assert "nonzero_cert" nonnegative "negative exponent" loc+  certifying c m++internaliseBinOp ::+  SrcLoc ->+  String ->+  E.BinOp ->+  I.SubExp ->+  I.SubExp ->+  E.PrimType ->+  E.PrimType ->+  InternaliseM [I.SubExp]+internaliseBinOp _ desc E.Plus x y (E.Signed t) _ =+  simpleBinOp desc (I.Add t I.OverflowWrap) x y+internaliseBinOp _ desc E.Plus x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Add t I.OverflowWrap) x y+internaliseBinOp _ desc E.Plus x y (E.FloatType t) _ =+  simpleBinOp desc (I.FAdd t) x y+internaliseBinOp _ desc E.Minus x y (E.Signed t) _ =+  simpleBinOp desc (I.Sub t I.OverflowWrap) x y+internaliseBinOp _ desc E.Minus x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Sub t I.OverflowWrap) x y+internaliseBinOp _ desc E.Minus x y (E.FloatType t) _ =+  simpleBinOp desc (I.FSub t) x y+internaliseBinOp _ desc E.Times x y (E.Signed t) _ =+  simpleBinOp desc (I.Mul t I.OverflowWrap) x y+internaliseBinOp _ desc E.Times x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Mul t I.OverflowWrap) x y+internaliseBinOp _ desc E.Times x y (E.FloatType t) _ =+  simpleBinOp desc (I.FMul t) x y+internaliseBinOp loc desc E.Divide x y (E.Signed t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.SDiv t I.Unsafe) x y+internaliseBinOp loc desc E.Divide x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.UDiv t I.Unsafe) x y+internaliseBinOp _ desc E.Divide x y (E.FloatType t) _ =+  simpleBinOp desc (I.FDiv t) x y+internaliseBinOp _ desc E.Pow x y (E.FloatType t) _ =+  simpleBinOp desc (I.FPow t) x y+internaliseBinOp loc desc E.Pow x y (E.Signed t) _ =+  certifyingNonnegative loc t y $+    simpleBinOp desc (I.Pow t) x y+internaliseBinOp _ desc E.Pow x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Pow t) x y+internaliseBinOp loc desc E.Mod x y (E.Signed t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.SMod t I.Unsafe) x y+internaliseBinOp loc desc E.Mod x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.UMod t I.Unsafe) x y+internaliseBinOp _ desc E.Mod x y (E.FloatType t) _ =+  simpleBinOp desc (I.FMod t) x y+internaliseBinOp loc desc E.Quot x y (E.Signed t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.SQuot t I.Unsafe) x y+internaliseBinOp loc desc E.Quot x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.UDiv t I.Unsafe) x y+internaliseBinOp loc desc E.Rem x y (E.Signed t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.SRem t I.Unsafe) x y+internaliseBinOp loc desc E.Rem x y (E.Unsigned t) _ =+  certifyingNonzero loc t y $+    simpleBinOp desc (I.UMod t I.Unsafe) x y+internaliseBinOp _ desc E.ShiftR x y (E.Signed t) _ =+  simpleBinOp desc (I.AShr t) x y+internaliseBinOp _ desc E.ShiftR x y (E.Unsigned t) _ =+  simpleBinOp desc (I.LShr t) x y+internaliseBinOp _ desc E.ShiftL x y (E.Signed t) _ =+  simpleBinOp desc (I.Shl t) x y+internaliseBinOp _ desc E.ShiftL x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Shl t) x y+internaliseBinOp _ desc E.Band x y (E.Signed t) _ =+  simpleBinOp desc (I.And t) x y+internaliseBinOp _ desc E.Band x y (E.Unsigned t) _ =+  simpleBinOp desc (I.And t) x y+internaliseBinOp _ desc E.Xor x y (E.Signed t) _ =+  simpleBinOp desc (I.Xor t) x y+internaliseBinOp _ desc E.Xor x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Xor t) x y+internaliseBinOp _ desc E.Bor x y (E.Signed t) _ =+  simpleBinOp desc (I.Or t) x y+internaliseBinOp _ desc E.Bor x y (E.Unsigned t) _ =+  simpleBinOp desc (I.Or t) x y+internaliseBinOp _ desc E.Equal x y t _ =+  simpleCmpOp desc (I.CmpEq $ internalisePrimType t) x y+internaliseBinOp _ desc E.NotEqual x y t _ = do+  eq <- letSubExp (desc ++ "true") $ I.BasicOp $ I.CmpOp (I.CmpEq $ internalisePrimType t) x y+  fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp I.Not eq+internaliseBinOp _ desc E.Less x y (E.Signed t) _ =+  simpleCmpOp desc (I.CmpSlt t) x y+internaliseBinOp _ desc E.Less x y (E.Unsigned t) _ =+  simpleCmpOp desc (I.CmpUlt t) x y+internaliseBinOp _ desc E.Leq x y (E.Signed t) _ =+  simpleCmpOp desc (I.CmpSle t) x y+internaliseBinOp _ desc E.Leq x y (E.Unsigned t) _ =+  simpleCmpOp desc (I.CmpUle t) x y+internaliseBinOp _ desc E.Greater x y (E.Signed t) _ =+  simpleCmpOp desc (I.CmpSlt t) y x -- Note the swapped x and y+internaliseBinOp _ desc E.Greater x y (E.Unsigned t) _ =+  simpleCmpOp desc (I.CmpUlt t) y x -- Note the swapped x and y+internaliseBinOp _ desc E.Geq x y (E.Signed t) _ =+  simpleCmpOp desc (I.CmpSle t) y x -- Note the swapped x and y+internaliseBinOp _ desc E.Geq x y (E.Unsigned t) _ =+  simpleCmpOp desc (I.CmpUle t) y x -- Note the swapped x and y+internaliseBinOp _ desc E.Less x y (E.FloatType t) _ =+  simpleCmpOp desc (I.FCmpLt t) x y+internaliseBinOp _ desc E.Leq x y (E.FloatType t) _ =+  simpleCmpOp desc (I.FCmpLe t) x y+internaliseBinOp _ desc E.Greater x y (E.FloatType t) _ =+  simpleCmpOp desc (I.FCmpLt t) y x -- Note the swapped x and y+internaliseBinOp _ desc E.Geq x y (E.FloatType t) _ =+  simpleCmpOp desc (I.FCmpLe t) y x -- Note the swapped x and y++-- Relational operators for booleans.+internaliseBinOp _ desc E.Less x y E.Bool _ =+  simpleCmpOp desc I.CmpLlt x y+internaliseBinOp _ desc E.Leq x y E.Bool _ =+  simpleCmpOp desc I.CmpLle x y+internaliseBinOp _ desc E.Greater x y E.Bool _ =+  simpleCmpOp desc I.CmpLlt y x -- Note the swapped x and y+internaliseBinOp _ desc E.Geq x y E.Bool _ =+  simpleCmpOp desc I.CmpLle y x -- Note the swapped x and y+internaliseBinOp _ _ op _ _ t1 t2 =+  error $+    "Invalid binary operator " ++ pretty op+      ++ " with operand types "+      ++ pretty t1+      ++ ", "+      ++ pretty t2++simpleBinOp ::+  String ->+  I.BinOp ->+  I.SubExp ->+  I.SubExp ->+  InternaliseM [I.SubExp]+simpleBinOp desc bop x y =+  letTupExp' desc $ I.BasicOp $ I.BinOp bop x y++simpleCmpOp ::+  String ->+  I.CmpOp ->+  I.SubExp ->+  I.SubExp ->+  InternaliseM [I.SubExp]+simpleCmpOp desc op x y =+  letTupExp' desc $ I.BasicOp $ I.CmpOp op x y++findFuncall ::+  E.AppExp ->+  InternaliseM+    ( E.QualName VName,+      [(E.Exp, Maybe VName)]+    )+findFuncall (E.Apply f arg (Info (_, argext)) _)+  | E.AppExp f_e _ <- f = do+    (fname, args) <- findFuncall f_e+    return (fname, args ++ [(arg, argext)])+  | E.Var fname _ _ <- f =+    return (fname, [(arg, argext)])+findFuncall e =+  error $ "Invalid function expression in application: " ++ pretty e++-- The type of a body.  Watch out: this only works for the degenerate+-- case where the body does not already return its context.+bodyExtType :: Body -> InternaliseM [ExtType]+bodyExtType (Body _ stms res) =+  existentialiseExtTypes (M.keys stmsscope) . staticShapes+    <$> extendedScope (traverse subExpType res) stmsscope+  where+    stmsscope = scopeOf stms++internaliseLambda :: InternaliseLambda+internaliseLambda (E.Parens e _) rowtypes =+  internaliseLambda e rowtypes+internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =+  bindingLambdaParams params rowtypes $ \params' -> do+    body' <- internaliseBody "lam" body+    rettype' <- internaliseLambdaReturnType rettype =<< bodyExtType body'+    return (params', body', rettype')+internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e++-- | Some operators and functions are overloaded or otherwise special+-- - we detect and treat them here.+isOverloadedFunction ::+  E.QualName VName ->+  [E.Exp] ->+  SrcLoc ->+  Maybe (String -> InternaliseM [SubExp])+isOverloadedFunction qname args loc = do+  guard $ baseTag (qualLeaf qname) <= maxIntrinsicTag+  let handlers =+        [ handleSign,+          handleIntrinsicOps,+          handleOps,+          handleSOACs,+          handleAccs,+          handleRest+        ]+  msum [h args $ baseString $ qualLeaf qname | h <- handlers]+  where+    handleSign [x] "sign_i8" = Just $ toSigned I.Int8 x+    handleSign [x] "sign_i16" = Just $ toSigned I.Int16 x+    handleSign [x] "sign_i32" = Just $ toSigned I.Int32 x+    handleSign [x] "sign_i64" = Just $ toSigned I.Int64 x+    handleSign [x] "unsign_i8" = Just $ toUnsigned I.Int8 x+    handleSign [x] "unsign_i16" = Just $ toUnsigned I.Int16 x+    handleSign [x] "unsign_i32" = Just $ toUnsigned I.Int32 x+    handleSign [x] "unsign_i64" = Just $ toUnsigned I.Int64 x+    handleSign _ _ = Nothing++    handleIntrinsicOps [x] s+      | Just unop <- find ((== s) . pretty) allUnOps = Just $ \desc -> do+        x' <- internaliseExp1 "x" x+        fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp unop x'+    handleIntrinsicOps [TupLit [x, y] _] s+      | Just bop <- find ((== s) . pretty) allBinOps = Just $ \desc -> do+        x' <- internaliseExp1 "x" x+        y' <- internaliseExp1 "y" y+        fmap pure $ letSubExp desc $ I.BasicOp $ I.BinOp bop x' y'+      | Just cmp <- find ((== s) . pretty) allCmpOps = Just $ \desc -> do+        x' <- internaliseExp1 "x" x+        y' <- internaliseExp1 "y" y+        fmap pure $ letSubExp desc $ I.BasicOp $ I.CmpOp cmp x' y'+    handleIntrinsicOps [x] s+      | Just conv <- find ((== s) . pretty) allConvOps = Just $ \desc -> do+        x' <- internaliseExp1 "x" x+        fmap pure $ letSubExp desc $ I.BasicOp $ I.ConvOp conv x'+    handleIntrinsicOps _ _ = Nothing++    -- Short-circuiting operators are magical.+    handleOps [x, y] "&&" = Just $ \desc ->+      internaliseExp desc $+        E.AppExp+          (E.If x y (E.Literal (E.BoolValue False) mempty) mempty)+          (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])+    handleOps [x, y] "||" = Just $ \desc ->+      internaliseExp desc $+        E.AppExp+          (E.If x (E.Literal (E.BoolValue True) mempty) y mempty)+          (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])+    -- Handle equality and inequality specially, to treat the case of+    -- arrays.+    handleOps [xe, ye] op+      | Just cmp_f <- isEqlOp op = Just $ \desc -> do+        xe' <- internaliseExp "x" xe+        ye' <- internaliseExp "y" ye+        rs <- zipWithM (doComparison desc) xe' ye'+        cmp_f desc =<< letSubExp "eq" =<< eAll rs+      where+        isEqlOp "!=" = Just $ \desc eq ->+          letTupExp' desc $ I.BasicOp $ I.UnOp I.Not eq+        isEqlOp "==" = Just $ \_ eq ->+          return [eq]+        isEqlOp _ = Nothing++        doComparison desc x y = do+          x_t <- I.subExpType x+          y_t <- I.subExpType y+          case x_t of+            I.Prim t -> letSubExp desc $ I.BasicOp $ I.CmpOp (I.CmpEq t) x y+            _ -> do+              let x_dims = I.arrayDims x_t+                  y_dims = I.arrayDims y_t+              dims_match <- forM (zip x_dims y_dims) $ \(x_dim, y_dim) ->+                letSubExp "dim_eq" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) x_dim y_dim+              shapes_match <- letSubExp "shapes_match" =<< eAll dims_match+              compare_elems_body <- runBodyBinder $ do+                -- Flatten both x and y.+                x_num_elems <-+                  letSubExp "x_num_elems"+                    =<< foldBinOp (I.Mul Int64 I.OverflowUndef) (constant (1 :: Int64)) x_dims+                x' <- letExp "x" $ I.BasicOp $ I.SubExp x+                y' <- letExp "x" $ I.BasicOp $ I.SubExp y+                x_flat <- letExp "x_flat" $ I.BasicOp $ I.Reshape [I.DimNew x_num_elems] x'+                y_flat <- letExp "y_flat" $ I.BasicOp $ I.Reshape [I.DimNew x_num_elems] y'++                -- Compare the elements.+                cmp_lam <- cmpOpLambda $ I.CmpEq (elemType x_t)+                cmps <-+                  letExp "cmps" $+                    I.Op $+                      I.Screma x_num_elems [x_flat, y_flat] (I.mapSOAC cmp_lam)++                -- Check that all were equal.+                and_lam <- binOpLambda I.LogAnd I.Bool+                reduce <- I.reduceSOAC [Reduce Commutative and_lam [constant True]]+                all_equal <- letSubExp "all_equal" $ I.Op $ I.Screma x_num_elems [cmps] reduce+                return $ resultBody [all_equal]++              letSubExp "arrays_equal" $+                I.If shapes_match compare_elems_body (resultBody [constant False]) $+                  ifCommon [I.Prim I.Bool]+    handleOps [x, y] name+      | Just bop <- find ((name ==) . pretty) [minBound .. maxBound :: E.BinOp] =+        Just $ \desc -> do+          x' <- internaliseExp1 "x" x+          y' <- internaliseExp1 "y" y+          case (E.typeOf x, E.typeOf y) of+            (E.Scalar (E.Prim t1), E.Scalar (E.Prim t2)) ->+              internaliseBinOp loc desc bop x' y' t1 t2+            _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in BinOp."+    handleOps _ _ = Nothing++    handleSOACs [TupLit [lam, arr] _] "map" = Just $ \desc -> do+      arr' <- internaliseExpToVars "map_arr" arr+      lam' <- internaliseMapLambda internaliseLambda lam $ map I.Var arr'+      w <- arraysSize 0 <$> mapM lookupType arr'+      letTupExp' desc $+        I.Op $+          I.Screma w arr' (I.mapSOAC lam')+    handleSOACs [TupLit [k, lam, arr] _] "partition" = do+      k' <- fromIntegral <$> fromInt32 k+      Just $ \_desc -> do+        arrs <- internaliseExpToVars "partition_input" arr+        lam' <- internalisePartitionLambda internaliseLambda k' lam $ map I.Var arrs+        uncurry (++) <$> partitionWithSOACS (fromIntegral k') lam' arrs+      where+        fromInt32 (Literal (SignedValue (Int32Value k')) _) = Just k'+        fromInt32 (IntLit k' (Info (E.Scalar (E.Prim (Signed Int32)))) _) = Just $ fromInteger k'+        fromInt32 _ = Nothing+    handleSOACs [TupLit [lam, ne, arr] _] "reduce" = Just $ \desc ->+      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)+      where+        reduce w red_lam nes arrs =+          I.Screma w arrs+            <$> I.reduceSOAC [Reduce Noncommutative red_lam nes]+    handleSOACs [TupLit [lam, ne, arr] _] "reduce_comm" = Just $ \desc ->+      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)+      where+        reduce w red_lam nes arrs =+          I.Screma w arrs+            <$> I.reduceSOAC [Reduce Commutative red_lam nes]+    handleSOACs [TupLit [lam, ne, arr] _] "scan" = Just $ \desc ->+      internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc)+      where+        reduce w scan_lam nes arrs =+          I.Screma w arrs <$> I.scanSOAC [Scan scan_lam nes]+    handleSOACs [TupLit [op, f, arr] _] "reduce_stream" = Just $ \desc ->+      internaliseStreamRed desc InOrder Noncommutative op f arr+    handleSOACs [TupLit [op, f, arr] _] "reduce_stream_per" = Just $ \desc ->+      internaliseStreamRed desc Disorder Commutative op f arr+    handleSOACs [TupLit [f, arr] _] "map_stream" = Just $ \desc ->+      internaliseStreamMap desc InOrder f arr+    handleSOACs [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->+      internaliseStreamMap desc Disorder f arr+    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->+      internaliseHist desc rf dest op ne buckets img loc+    handleSOACs _ _ = Nothing++    handleAccs [TupLit [dest, f, bs] _] "scatter_stream" = Just $ \desc ->+      internaliseStreamAcc desc dest Nothing f bs+    handleAccs [TupLit [dest, op, ne, f, bs] _] "hist_stream" = Just $ \desc ->+      internaliseStreamAcc desc dest (Just (op, ne)) f bs+    handleAccs [TupLit [acc, i, v] _] "acc_write" = Just $ \desc -> do+      acc' <- head <$> internaliseExpToVars "acc" acc+      i' <- internaliseExp1 "acc_i" i+      vs <- internaliseExp "acc_v" v+      fmap pure $ letSubExp desc $ BasicOp $ UpdateAcc acc' [i'] vs+    handleAccs _ _ = Nothing++    handleRest [x] "!" = Just $ complementF x+    handleRest [x] "opaque" = Just $ \desc ->+      mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x+    handleRest [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF 1 a si v+    handleRest [E.TupLit [a, si, v] _] "scatter_2d" = Just $ scatterF 2 a si v+    handleRest [E.TupLit [a, si, v] _] "scatter_3d" = Just $ scatterF 3 a si v+    handleRest [E.TupLit [n, m, arr] _] "unflatten" = Just $ \desc -> do+      arrs <- internaliseExpToVars "unflatten_arr" arr+      n' <- internaliseExp1 "n" n+      m' <- internaliseExp1 "m" m+      -- The unflattened dimension needs to have the same number of elements+      -- as the original dimension.+      old_dim <- I.arraysSize 0 <$> mapM lookupType arrs+      dim_ok <-+        letSubExp "dim_ok"+          =<< eCmpOp+            (I.CmpEq I.int64)+            (eBinOp (I.Mul Int64 I.OverflowUndef) (eSubExp n') (eSubExp m'))+            (eSubExp old_dim)+      dim_ok_cert <-+        assert+          "dim_ok_cert"+          dim_ok+          "new shape has different number of elements than old shape"+          loc+      certifying dim_ok_cert $+        forM arrs $ \arr' -> do+          arr_t <- lookupType arr'+          letSubExp desc $+            I.BasicOp $+              I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ I.arrayShape arr_t) arr'+    handleRest [arr] "flatten" = Just $ \desc -> do+      arrs <- internaliseExpToVars "flatten_arr" arr+      forM arrs $ \arr' -> do+        arr_t <- lookupType arr'+        let n = arraySize 0 arr_t+            m = arraySize 1 arr_t+        k <- letSubExp "flat_dim" $ I.BasicOp $ I.BinOp (Mul Int64 I.OverflowUndef) n m+        letSubExp desc $+          I.BasicOp $+            I.Reshape (reshapeOuter [DimNew k] 2 $ I.arrayShape arr_t) arr'+    handleRest [TupLit [x, y] _] "concat" = Just $ \desc -> do+      xs <- internaliseExpToVars "concat_x" x+      ys <- internaliseExpToVars "concat_y" y+      outer_size <- arraysSize 0 <$> mapM lookupType xs+      let sumdims xsize ysize =+            letSubExp "conc_tmp" $+              I.BasicOp $+                I.BinOp (I.Add I.Int64 I.OverflowUndef) xsize ysize+      ressize <-+        foldM sumdims outer_size+          =<< mapM (fmap (arraysSize 0) . mapM lookupType) [ys]++      let conc xarr yarr =+            I.BasicOp $ I.Concat 0 xarr [yarr] ressize+      letSubExps desc $ zipWith conc xs ys+    handleRest [TupLit [offset, e] _] "rotate" = Just $ \desc -> do+      offset' <- internaliseExp1 "rotation_offset" offset+      internaliseOperation desc e $ \v -> do+        r <- I.arrayRank <$> lookupType v+        let zero = intConst Int64 0+            offsets = offset' : replicate (r -1) zero+        return $ I.Rotate offsets v+    handleRest [e] "transpose" = Just $ \desc ->+      internaliseOperation desc e $ \v -> do+        r <- I.arrayRank <$> lookupType v+        return $ I.Rearrange ([1, 0] ++ [2 .. r -1]) v+    handleRest [TupLit [x, y] _] "zip" = Just $ \desc ->+      mapM (letSubExp "zip_copy" . BasicOp . Copy)+        =<< ( (++)+                <$> internaliseExpToVars (desc ++ "_zip_x") x+                <*> internaliseExpToVars (desc ++ "_zip_y") y+            )+    handleRest [x] "unzip" = Just $ flip internaliseExp x+    handleRest [x] "trace" = Just $ flip internaliseExp x+    handleRest [x] "break" = Just $ flip internaliseExp x+    handleRest _ _ = Nothing++    toSigned int_to e desc = do+      e' <- internaliseExp1 "trunc_arg" e+      case E.typeOf e of+        E.Scalar (E.Prim E.Bool) ->+          letTupExp' desc $+            I.If+              e'+              (resultBody [intConst int_to 1])+              (resultBody [intConst int_to 0])+              $ ifCommon [I.Prim $ I.IntType int_to]+        E.Scalar (E.Prim (E.Signed int_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.SExt int_from int_to) e'+        E.Scalar (E.Prim (E.Unsigned int_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'+        E.Scalar (E.Prim (E.FloatType float_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToSI float_from int_to) e'+        _ -> error "Futhark.Internalise: non-numeric type in ToSigned"++    toUnsigned int_to e desc = do+      e' <- internaliseExp1 "trunc_arg" e+      case E.typeOf e of+        E.Scalar (E.Prim E.Bool) ->+          letTupExp' desc $+            I.If+              e'+              (resultBody [intConst int_to 1])+              (resultBody [intConst int_to 0])+              $ ifCommon [I.Prim $ I.IntType int_to]+        E.Scalar (E.Prim (E.Signed int_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'+        E.Scalar (E.Prim (E.Unsigned int_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'+        E.Scalar (E.Prim (E.FloatType float_from)) ->+          letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToUI float_from int_to) e'+        _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in ToUnsigned"++    complementF e desc = do+      e' <- internaliseExp1 "complement_arg" e+      et <- subExpType e'+      case et of+        I.Prim (I.IntType t) ->+          letTupExp' desc $ I.BasicOp $ I.UnOp (I.Complement t) e'+        I.Prim I.Bool ->+          letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e'+        _ ->+          error "Futhark.Internalise.internaliseExp: non-int/bool type in Complement"++    scatterF dim a si v desc = do+      si' <- internaliseExpToVars "write_arg_i" si+      svs <- internaliseExpToVars "write_arg_v" v+      sas <- internaliseExpToVars "write_arg_a" a++      si_w <- I.arraysSize 0 <$> mapM lookupType si'+      sv_ts <- mapM lookupType svs++      svs' <- forM (zip svs sv_ts) $ \(sv, sv_t) -> do+        let sv_shape = I.arrayShape sv_t+            sv_w = arraySize 0 sv_t++        -- Generate an assertion and reshapes to ensure that sv and si' are the same+        -- size.+        cmp <-+          letSubExp "write_cmp" $+            I.BasicOp $+              I.CmpOp (I.CmpEq I.int64) si_w sv_w+        c <-+          assert+            "write_cert"+            cmp+            "length of index and value array does not match"+            loc+        certifying c $+          letExp (baseString sv ++ "_write_sv") $+            I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion si_w] 1 sv_shape) sv++      indexType <- fmap rowType <$> mapM lookupType si'+      indexName <- mapM (\_ -> newVName "write_index") indexType+      valueNames <- replicateM (length sv_ts) $ newVName "write_value"++      sa_ts <- mapM lookupType sas+      let bodyTypes = concat (replicate (length sv_ts) indexType) ++ map (I.stripArray dim) sa_ts+          paramTypes = indexType <> map rowType sv_ts+          bodyNames = indexName <> valueNames+          bodyParams = zipWith I.Param bodyNames paramTypes++      -- This body is pretty boring right now, as every input is exactly the output.+      -- But it can get funky later on if fused with something else.+      body <- localScope (scopeOfLParams bodyParams) . buildBody_ $ do+        let outs = concat (replicate (length valueNames) indexName) ++ valueNames+        results <- forM outs $ \name ->+          letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name+        ensureResultShape+          "scatter value has wrong size"+          loc+          bodyTypes+          results++      let lam =+            I.Lambda+              { I.lambdaParams = bodyParams,+                I.lambdaReturnType = bodyTypes,+                I.lambdaBody = body+              }+          sivs = si' <> svs'++      let sa_ws = map (Shape . take dim . arrayDims) sa_ts+      letTupExp' desc $ I.Op $ I.Scatter si_w lam sivs $ zip3 sa_ws (repeat 1) sas++funcall ::+  String ->+  QualName VName ->+  [SubExp] ->+  SrcLoc ->+  InternaliseM ([SubExp], [I.ExtType])+funcall desc (QualName _ fname) args loc = do+  (shapes, value_paramts, fun_params, rettype_fun) <-+    lookupFunction fname+  argts <- mapM subExpType args++  shapeargs <- argShapes shapes fun_params argts+  let diets =+        replicate (length shapeargs) I.ObservePrim+          ++ map I.diet value_paramts+  args' <-+    ensureArgShapes+      "function arguments of wrong shape"+      loc+      (map I.paramName fun_params)+      (map I.paramType fun_params)+      (shapeargs ++ args)+  argts' <- mapM subExpType args'+  case rettype_fun $ zip args' argts' of+    Nothing ->+      error $+        concat+          [ "Cannot apply ",+            pretty fname,+            " to ",+            show (length args'),+            " arguments\n ",+            pretty args',+            "\nof types\n ",+            pretty argts',+            "\nFunction has ",+            show (length fun_params),+            " parameters\n ",+            pretty fun_params+          ]+    Just ts -> do+      safety <- askSafety+      attrs <- asks envAttrs+      ses <-+        attributing attrs $+          letTupExp' desc $+            I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)+      return (ses, map I.fromDecl ts)++-- Bind existential names defined by an expression, based on the+-- concrete values that expression evaluated to.  This most+-- importantly should be done after function calls, but also+-- everything else that can produce existentials in the source+-- language.+bindExtSizes :: AppRes -> [SubExp] -> InternaliseM ()+bindExtSizes (AppRes ret retext) ses = do+  ts <- internaliseType $ E.toStruct ret+  ses_ts <- mapM subExpType ses++  let combine t1 t2 =+        mconcat $ zipWith combine' (arrayExtDims t1) (arrayDims t2)+      combine' (I.Free (I.Var v)) se+        | v `elem` retext = M.singleton v se+      combine' _ _ = mempty++  forM_ (M.toList $ mconcat $ zipWith combine ts ses_ts) $ \(v, se) ->+    letBindNames [v] $ BasicOp $ SubExp se++askSafety :: InternaliseM Safety+askSafety = do+  check <- asks envDoBoundsChecks+  return $ if check then I.Safe else I.Unsafe++-- Implement partitioning using maps, scans and writes.+partitionWithSOACS :: Int -> I.Lambda -> [I.VName] -> InternaliseM ([I.SubExp], [I.SubExp])+partitionWithSOACS k lam arrs = do+  arr_ts <- mapM lookupType arrs+  let w = arraysSize 0 arr_ts+  classes_and_increments <- letTupExp "increments" $ I.Op $ I.Screma w arrs (mapSOAC lam)+  (classes, increments) <- case classes_and_increments of+    classes : increments -> return (classes, take k increments)+    _ -> error "partitionWithSOACS"++  add_lam_x_params <-+    replicateM k $ I.Param <$> newVName "x" <*> pure (I.Prim int64)+  add_lam_y_params <-+    replicateM k $ I.Param <$> newVName "y" <*> pure (I.Prim int64)+  add_lam_body <- runBodyBinder $+    localScope (scopeOfLParams $ add_lam_x_params ++ add_lam_y_params) $+      fmap resultBody $+        forM (zip add_lam_x_params add_lam_y_params) $ \(x, y) ->+          letSubExp "z" $+            I.BasicOp $+              I.BinOp+                (I.Add Int64 I.OverflowUndef)+                (I.Var $ I.paramName x)+                (I.Var $ I.paramName y)+  let add_lam =+        I.Lambda+          { I.lambdaBody = add_lam_body,+            I.lambdaParams = add_lam_x_params ++ add_lam_y_params,+            I.lambdaReturnType = replicate k $ I.Prim int64+          }+      nes = replicate (length increments) $ intConst Int64 0++  scan <- I.scanSOAC [I.Scan add_lam nes]+  all_offsets <- letTupExp "offsets" $ I.Op $ I.Screma w increments scan++  -- We have the offsets for each of the partitions, but we also need+  -- the total sizes, which are the last elements in the offests.  We+  -- just have to be careful in case the array is empty.+  last_index <- letSubExp "last_index" $ I.BasicOp $ I.BinOp (I.Sub Int64 OverflowUndef) w $ constant (1 :: Int64)+  nonempty_body <- runBodyBinder $+    fmap resultBody $+      forM all_offsets $ \offset_array ->+        letSubExp "last_offset" $ I.BasicOp $ I.Index offset_array [I.DimFix last_index]+  let empty_body = resultBody $ replicate k $ constant (0 :: Int64)+  is_empty <- letSubExp "is_empty" $ I.BasicOp $ I.CmpOp (CmpEq int64) w $ constant (0 :: Int64)+  sizes <-+    letTupExp "partition_size" $+      I.If is_empty empty_body nonempty_body $+        ifCommon $ replicate k $ I.Prim int64++  -- The total size of all partitions must necessarily be equal to the+  -- size of the input array.++  -- Create scratch arrays for the result.+  blanks <- forM arr_ts $ \arr_t ->+    letExp "partition_dest" $+      I.BasicOp $ Scratch (I.elemType arr_t) (w : drop 1 (I.arrayDims arr_t))++  -- Now write into the result.+  write_lam <- do+    c_param <- I.Param <$> newVName "c" <*> pure (I.Prim int64)+    offset_params <- replicateM k $ I.Param <$> newVName "offset" <*> pure (I.Prim int64)+    value_params <- forM arr_ts $ \arr_t ->+      I.Param <$> newVName "v" <*> pure (I.rowType arr_t)+    (offset, offset_stms) <-+      collectStms $+        mkOffsetLambdaBody+          (map I.Var sizes)+          (I.Var $ I.paramName c_param)+          0+          offset_params+    return+      I.Lambda+        { I.lambdaParams = c_param : offset_params ++ value_params,+          I.lambdaReturnType =+            replicate (length arr_ts) (I.Prim int64)+              ++ map I.rowType arr_ts,+          I.lambdaBody =+            mkBody offset_stms $+              replicate (length arr_ts) offset+                ++ map (I.Var . I.paramName) value_params+        }+  results <-+    letTupExp "partition_res" $+      I.Op $+        I.Scatter+          w+          write_lam+          (classes : all_offsets ++ arrs)+          $ zip3 (repeat $ Shape [w]) (repeat 1) blanks+  sizes' <-+    letSubExp "partition_sizes" $+      I.BasicOp $+        I.ArrayLit (map I.Var sizes) $ I.Prim int64+  return (map I.Var results, [sizes'])+  where+    mkOffsetLambdaBody ::+      [SubExp] ->+      SubExp ->+      Int ->+      [I.LParam] ->+      InternaliseM SubExp+    mkOffsetLambdaBody _ _ _ [] =+      return $ constant (-1 :: Int64)+    mkOffsetLambdaBody sizes c i (p : ps) = do+      is_this_one <-+        letSubExp "is_this_one" $+          I.BasicOp $+            I.CmpOp (CmpEq int64) c $+              intConst Int64 $ toInteger i+      next_one <- mkOffsetLambdaBody sizes c (i + 1) ps+      this_one <-+        letSubExp "this_offset"+          =<< foldBinOp+            (Add Int64 OverflowUndef)+            (constant (-1 :: Int64))+            (I.Var (I.paramName p) : take i sizes)+      letSubExp "total_res" $+        I.If+          is_this_one+          (resultBody [this_one])+          (resultBody [next_one])+          $ ifCommon [I.Prim int64]++typeExpForError :: E.TypeExp VName -> InternaliseM [ErrorMsgPart SubExp]+typeExpForError (E.TEVar qn _) =+  return [ErrorString $ pretty qn]+typeExpForError (E.TEUnique te _) =+  ("*" :) <$> typeExpForError te+typeExpForError (E.TEArray te d _) = do+  d' <- dimExpForError d+  te' <- typeExpForError te+  return $ ["[", d', "]"] ++ te'+typeExpForError (E.TETuple tes _) = do+  tes' <- mapM typeExpForError tes+  return $ ["("] ++ intercalate [", "] tes' ++ [")"]+typeExpForError (E.TERecord fields _) = do+  fields' <- mapM onField fields+  return $ ["{"] ++ intercalate [", "] fields' ++ ["}"]+  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 (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 (E.TESum cs _) = do+  cs' <- mapM (onClause . snd) cs+  return $ intercalate [" | "] cs'+  where+    onClause c = do+      c' <- mapM typeExpForError c+      return $ intercalate [" "] c'++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 $ ErrorInt64 d'+dimExpForError (DimExpConst d _) =+  return $ ErrorString $ pretty d+dimExpForError DimExpAny = return ""++-- A smart constructor that compacts neighbouring literals for easier+-- reading in the IR.+errorMsg :: [ErrorMsgPart a] -> ErrorMsg a+errorMsg = ErrorMsg . compact+  where+    compact [] = []+    compact (ErrorString x : ErrorString y : parts) =+      compact (ErrorString (x ++ y) : parts)+    compact (x : y) = x : compact y

@@ -29,7 +29,8 @@ where  import Control.Monad.Except-import Control.Monad.RWS+import Control.Monad.Reader+import Control.Monad.State import qualified Data.Map.Strict as M import Futhark.IR.SOACS import Futhark.MonadFreshNames@@ -60,29 +61,13 @@   { stateNameSource :: VNameSource,     stateFunTable :: FunTable,     stateConstSubsts :: VarSubstitutions,-    stateConstScope :: Scope SOACS+    stateConstScope :: Scope SOACS,+    stateFuns :: [FunDef SOACS]   } -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-              InternaliseResult-              InternaliseState-          )-          a-      )+      (BinderT SOACS (ReaderT InternaliseEnv (State InternaliseState)) a)   deriving     ( Functor,       Applicative,@@ -94,7 +79,7 @@       LocalScope SOACS     ) -instance (Monoid w, Monad m) => MonadFreshNames (RWST r w InternaliseState m) where+instance MonadFreshNames (State InternaliseState) where   getNameSource = gets stateNameSource   putNameSource src = modify $ \s -> s {stateNameSource = src} @@ -114,9 +99,9 @@   m (Stms SOACS, [FunDef SOACS]) runInternaliseM safe (InternaliseM m) =   modifyNameSource $ \src ->-    let ((_, consts), s, InternaliseResult _ funs) =-          runRWS (runBinderT m mempty) newEnv (newState src)-     in ((consts, funs), stateNameSource s)+    let ((_, consts), s) =+          runState (runReaderT (runBinderT m mempty) newEnv) (newState src)+     in ((consts, reverse $ stateFuns s), stateNameSource s)   where     newEnv =       InternaliseEnv@@ -130,7 +115,8 @@         { stateNameSource = src,           stateFunTable = mempty,           stateConstSubsts = mempty,-          stateConstScope = mempty+          stateConstScope = mempty,+          stateFuns = mempty         }  substitutingVars :: VarSubstitutions -> InternaliseM a -> InternaliseM a@@ -144,8 +130,7 @@  -- | Add a function definition to the program being constructed. addFunDef :: FunDef SOACS -> InternaliseM ()-addFunDef fd =-  InternaliseM $ lift $ tell $ InternaliseResult mempty [fd]+addFunDef fd = modify $ \s -> s {stateFuns = fd : stateFuns s}  lookupFunction' :: VName -> InternaliseM (Maybe FunInfo) lookupFunction' fname = gets $ M.lookup fname . stateFunTable

@@ -200,8 +200,11 @@  -- | How many core language values are needed to represent one source -- language value of the given type?-internalisedTypeSize :: E.TypeBase (E.DimDecl VName) () -> InternaliseM Int-internalisedTypeSize = fmap length . internaliseType+internalisedTypeSize :: E.TypeBase (E.DimDecl VName) als -> InternaliseM Int+-- A few special cases for performance.+internalisedTypeSize (E.Scalar (E.Prim _)) = pure 1+internalisedTypeSize (E.Array _ _ (E.Prim _) _) = pure 1+internalisedTypeSize t = length <$> internaliseType (t `E.setAliases` ())  -- | Convert an external primitive to an internal primitive. internalisePrimType :: E.PrimType -> I.PrimType

@@ -425,8 +425,10 @@   --   -- (ii) check whether fusing @soac@ will violate any in-place update   --      restriction, e.g., would move an input array past its in-place update.-  let all_used_names = namesToList $ mconcat [lam_used_nms, namesFromList inp_nms, namesFromList other_nms]-      has_inplace ker = any (`nameIn` inplace ker) all_used_names+  all_used_names <-+    fmap mconcat . mapM varAliases . namesToList $+      mconcat [lam_used_nms, namesFromList inp_nms, namesFromList other_nms]+  let has_inplace ker = inplace ker `namesIntersect` all_used_names       ok_inplace = not $ any has_inplace old_kers   --   -- (iii)  there are some kernels that use some of `out_idds' as inputs

@@ -11,7 +11,9 @@ import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) import qualified Data.Sequence as Seq+import qualified Futhark.Analysis.Alias as Alias import Futhark.IR.Kernels+import Futhark.IR.Prop.Aliases (consumedInStm) import Futhark.MonadFreshNames import Futhark.Optimise.BlkRegTiling import Futhark.Optimise.TileLoops.Shared@@ -255,13 +257,25 @@     invariantTo names stm =       case patternNames (stmPattern stm) of         [] -> True -- Does not matter.-        v : _ ->-          not $-            any (`nameIn` names) $-              namesToList $-                M.findWithDefault mempty v variance+        v : _ -> not $ any (`nameIn` names) $ namesToList $ M.findWithDefault mempty v variance++    consumed v = v `nameIn` consumed_in_prestms+    consumedStm stm = any consumed (patternNames (stmPattern stm))++    later_consumed =+      namesFromList $+        concatMap (patternNames . stmPattern) $+          stmsToList $ Seq.filter consumedStm prestms++    groupInvariant stm =+      invariantTo private stm+        && not (any (`nameIn` later_consumed) (patternNames (stmPattern stm)))+        && invariantTo later_consumed stm     (invariant_prestms, variant_prestms) =-      Seq.partition (invariantTo private) prestms+      Seq.partition groupInvariant prestms++    consumed_in_prestms =+      foldMap consumedInStm $ fst $ Alias.analyseStms mempty prestms      mustBeInlinedExp (BasicOp (Index _ slice)) = not $ null $ sliceDims slice     mustBeInlinedExp (BasicOp Rotate {}) = True

@@ -21,7 +21,6 @@  import Control.Monad import Control.Monad.Writer-import Data.List () import Futhark.Analysis.PrimExp import Futhark.IR import Futhark.IR.Prop.Aliases@@ -244,11 +243,11 @@   m () readKernelInput inp = do   let pe = PatElem (kernelInputName inp) $ kernelInputType inp-  arr_t <- lookupType $ kernelInputArray inp   letBind (Pattern [] [pe]) . BasicOp $-    case arr_t of+    case kernelInputType inp of       Acc {} ->         SubExp $ Var $ kernelInputArray inp       _ ->         Index (kernelInputArray inp) $-          fullSlice arr_t $ map DimFix $ kernelInputIndices inp+          map DimFix (kernelInputIndices inp)+            ++ map sliceDim (arrayDims (kernelInputType inp))

@@ -9,6 +9,7 @@   ( -- * Server     ScriptServer,     withScriptServer,+    withScriptServer',      -- * Expressions, values, and types     Func (..),@@ -18,6 +19,8 @@     ScriptValueType (..),     ScriptValue (..),     scriptValueType,+    serverVarsInValue,+    ValOrVar (..),     ExpValue,      -- * Evaluation@@ -35,6 +38,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Foldable (toList)+import Data.Functor import Data.IORef import Data.List (intersperse) import qualified Data.Map as M@@ -56,12 +60,18 @@ -- more convenient. data ScriptServer = ScriptServer Server (IORef Int) +-- | Run an action with a 'ScriptServer' produced by an existing+-- 'Server', without shutting it down at the end.+withScriptServer' :: MonadIO m => Server -> (ScriptServer -> m a) -> m a+withScriptServer' server f = do+  counter <- liftIO $ newIORef 0+  f $ ScriptServer server counter+ -- | Start a server, execute an action, then shut down the server. -- Similar to 'withServer'. withScriptServer :: FilePath -> [FilePath] -> (ScriptServer -> IO a) -> IO a-withScriptServer prog options f = withServer prog options $ \server -> do-  counter <- newIORef 0-  f $ ScriptServer server counter+withScriptServer prog options f =+  withServer prog options $ flip withScriptServer' f  -- | A function called in a 'Call' expression can be either a Futhark -- function or a builtin function.@@ -78,6 +88,7 @@   | Tuple [Exp]   | Record [(T.Text, Exp)]   | StringLit T.Text+  | Let [VarName] Exp Exp   | -- | Server-side variable, *not* Futhark variable (these are     -- handled in 'Call').     ServerVar TypeName VarName@@ -91,6 +102,12 @@   ppr = pprPrec 0   pprPrec _ (ServerVar _ v) = "$" <> ppr v   pprPrec _ (Const v) = ppr v+  pprPrec i (Let pat e1 e2) =+    parensIf (i > 0) $ "let" <+> pat' <+> equals <+> ppr e1 <+> "in" <+> ppr e2+    where+      pat' = case pat of+        [x] -> ppr x+        _ -> parens $ commasep $ map ppr pat   pprPrec _ (Call v []) = ppr v   pprPrec i (Call v args) =     parensIf (i > 0) $ ppr v <+> spread (map (pprPrec 1) args)@@ -116,27 +133,42 @@ parseExp :: Parser () -> Parser Exp parseExp sep =   choice-    [ inParens sep (mkTuple <$> (parseExp sep `sepBy` pComma)),+    [ lexeme sep "let" $> Let+        <*> pPattern <* lexeme sep "="+        <*> parseExp sep <* lexeme sep "in"+        <*> parseExp sep,+      inParens sep (mkTuple <$> (parseExp sep `sepBy` pComma)),       inBraces sep (Record <$> (pField `sepBy` pComma)),-      Call <$> lexeme sep parseFunc <*> many (parseExp sep),+      Call <$> parseFunc <*> many (parseExp sep),       Const <$> V.parseValue sep,       StringLit . T.pack <$> lexeme sep ("\"" *> manyTill charLiteral "\"")     ]+    <?> "expression"   where-    pField = (,) <$> lexeme sep parseEntryName <*> (pEquals *> parseExp sep)+    pField = (,) <$> pVarName <*> (pEquals *> parseExp sep)     pEquals = lexeme sep "="     pComma = lexeme sep ","     mkTuple [v] = v     mkTuple vs = Tuple vs +    pPattern =+      choice+        [ inParens sep $ pVarName `sepBy` pComma,+          pure <$> pVarName+        ]+     parseFunc =       choice-        [ FuncBuiltin <$> ("$" *> parseEntryName),-          FuncFut <$> parseEntryName+        [ FuncBuiltin <$> ("$" *> pVarName),+          FuncFut <$> pVarName         ] -    parseEntryName =-      fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent)+    reserved = ["let", "in"]++    pVarName = lexeme sep . try $ do+      v <- fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent)+      guard $ v `notElem` reserved+      pure v       where         constituent c = isAlphaNum c || c == '_' @@ -144,12 +176,6 @@ prettyFailure (CmdFailure bef aft) =   T.unlines $ bef ++ aft -cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()-cmdMaybe m = maybe (pure ()) (throwError . prettyFailure) =<< liftIO m--cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a-cmdEither m = either (throwError . prettyFailure) pure =<< liftIO m- readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value readVar server v =   either throwError pure <=< liftIO $@@ -184,6 +210,7 @@   | -- | Ins, then outs.  Yes, this is the opposite of more or less     -- everywhere else.     SFun EntryName [TypeName] [TypeName] [ScriptValue v]+  deriving (Show)  instance Functor ScriptValue where   fmap = fmapDefault@@ -212,6 +239,7 @@         [out] -> strictText out         _ -> parens $ commasep $ map strictText outs +-- | A Haskell-level value or a variable on the server. data ValOrVar = VVal V.Value | VVar VarName   deriving (Show) @@ -224,6 +252,7 @@ scriptValueType (SValue t _) = STValue t scriptValueType (SFun _ ins outs _) = STFun ins outs +-- | The set of server-side variables in the value. serverVarsInValue :: ExpValue -> S.Set VarName serverVarsInValue = S.fromList . concatMap isVar . toList   where@@ -247,6 +276,9 @@ -- | How to evaluate a builtin function. type EvalBuiltin m = T.Text -> [V.CompoundValue] -> m V.CompoundValue +-- | Symbol table used for local variable lookups during expression evaluation.+type VTable = M.Map VarName ExpValue+ -- | Evaluate a FutharkScript expression relative to some running server. evalExp ::   forall m.@@ -300,17 +332,33 @@       simpleType (V.ValueAtom (STValue _)) = True       simpleType _ = False -      evalExp' :: Exp -> m ExpValue-      evalExp' (ServerVar t v) =+      letMatch :: [VarName] -> ExpValue -> m VTable+      letMatch vs val+        | vals <- V.unCompound val,+          length vs == length vals =+          pure $ M.fromList (zip vs vals)+        | otherwise =+          throwError $+            "Pattern: " <> prettyTextOneLine vs+              <> "\nDoes not match value of type: "+              <> prettyTextOneLine (fmap scriptValueType val)++      evalExp' :: VTable -> Exp -> m ExpValue+      evalExp' _ (ServerVar t v) =         pure $ V.ValueAtom $ SValue t $ VVar v-      evalExp' (Call (FuncBuiltin name) es) = do-        v <- builtin name =<< mapM (interValToVal <=< evalExp') es+      evalExp' vtable (Call (FuncBuiltin name) es) = do+        v <- builtin name =<< mapM (interValToVal <=< evalExp' vtable) es         pure $ valToInterVal v-      evalExp' (Call (FuncFut name) es) = do+      evalExp' vtable (Call (FuncFut name) es)+        | Just e <- M.lookup name vtable = do+          unless (null es) $+            throwError $ "Locally bound name cannot be invoked as a function: " <> prettyText name+          pure e+      evalExp' vtable (Call (FuncFut name) es) = do         in_types <- cmdEither $ cmdInputs server name         out_types <- cmdEither $ cmdOutputs server name -        es' <- mapM evalExp' es+        es' <- mapM (evalExp' vtable) es         let es_types = map (fmap scriptValueType) es'          unless (all simpleType es_types) $@@ -318,15 +366,17 @@             "Literate Futhark does not support passing script-constructed records, tuples, or functions to entry points.\n"               <> "Create a Futhark wrapper function." -        -- Careful to not require saturated application.-        unless (and $ zipWith (==) es_types (map (V.ValueAtom . STValue) in_types)) $-          throwError $-            "Function \"" <> name <> "\" expects arguments of types:\n"-              <> prettyText (V.mkCompound $ map V.ValueAtom in_types)-              <> "\nBut called with arguments of types:\n"-              <> prettyText (V.mkCompound $ map V.ValueAtom es_types)+        -- Careful to not require saturated application, but do still+        -- check for over-saturation.+        let too_many = length es_types > length in_types+            too_wrong = zipWith (/=) es_types (map (V.ValueAtom . STValue) in_types)+        when (or $ too_many : too_wrong) . throwError $+          "Function \"" <> name <> "\" expects arguments of types:\n"+            <> prettyText (V.mkCompound $ map V.ValueAtom in_types)+            <> "\nBut called with arguments of types:\n"+            <> prettyText (V.mkCompound $ map V.ValueAtom es_types) -        ins <- mapM (interValToVar <=< evalExp') es+        ins <- mapM (interValToVar <=< evalExp' vtable) es          if length in_types == length ins           then do@@ -336,19 +386,23 @@           else             pure . V.ValueAtom . SFun name in_types out_types $               zipWith SValue in_types $ map VVar ins-      evalExp' (StringLit s) =+      evalExp' _ (StringLit s) =         case V.putValue s of           Just s' ->             pure $ V.ValueAtom $ SValue (prettyText (V.valueType s')) $ VVal s'           Nothing -> error $ "Unable to write value " ++ pretty s-      evalExp' (Const val) =+      evalExp' _ (Const val) =         pure $ V.ValueAtom $ SValue (V.prettyValueTypeNoDims (V.valueType val)) $ VVal val-      evalExp' (Tuple es) =-        V.ValueTuple <$> mapM evalExp' es-      evalExp' e@(Record m) = do+      evalExp' vtable (Tuple es) =+        V.ValueTuple <$> mapM (evalExp' vtable) es+      evalExp' vtable e@(Record m) = do         when (length (nubOrd (map fst m)) /= length (map fst m)) $           throwError $ "Record " <> prettyText e <> " has duplicate fields."-        V.ValueRecord <$> traverse evalExp' (M.fromList m)+        V.ValueRecord <$> traverse (evalExp' vtable) (M.fromList m)+      evalExp' vtable (Let pat e1 e2) = do+        v <- evalExp' vtable e1+        pat_vtable <- letMatch pat v+        evalExp' (pat_vtable <> vtable) e2    let freeNonresultVars v = do         let v_vars = serverVarsInValue v@@ -363,7 +417,7 @@         -- Call.         void $ liftIO $ cmdFree server =<< readIORef vars         throwError e-  (freeNonresultVars =<< evalExp' top_level_e) `catchError` freeVarsOnError+  (freeNonresultVars =<< evalExp' mempty top_level_e) `catchError` freeVarsOnError  -- | Read actual values from the server.  Fails for values that have -- no well-defined external representation.@@ -405,6 +459,7 @@ varsInExp (Record fs) = foldMap (foldMap varsInExp) fs varsInExp Const {} = mempty varsInExp StringLit {} = mempty+varsInExp (Let pat e1 e2) = varsInExp e1 <> S.filter (`notElem` pat) (varsInExp e2)  -- | Release all the server-side variables in the value.  Yes, -- FutharkScript has manual memory management...

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}  -- | Haskell code for interacting with a Futhark server program (a@@ -13,15 +14,19 @@     cmdStore,     cmdCall,     cmdFree,+    cmdRename,     cmdInputs,     cmdOutputs,     cmdClear,     cmdReport,+    cmdMaybe,+    cmdEither,   ) where  import Control.Exception import Control.Monad+import Control.Monad.Except import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -180,6 +185,9 @@ cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure) cmdFree s vs = helpCmd s $ "free" : vs +cmdRename :: Server -> VarName -> VarName -> IO (Maybe CmdFailure)+cmdRename s oldname newname = helpCmd s ["rename", oldname, newname]+ cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName]) cmdInputs s entry =   sendCommand s ["inputs", entry]@@ -193,3 +201,11 @@  cmdReport :: Server -> IO (Either CmdFailure [T.Text]) cmdReport s = sendCommand s ["report"]++-- | Turn a 'Maybe'-producing command into a monadic action.+cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()+cmdMaybe = maybe (pure ()) (throwError . T.unlines . failureMsg) <=< liftIO++-- | Turn an 'Either'-producing command into a monadic action.+cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a+cmdEither = either (throwError . T.unlines . failureMsg) pure <=< liftIO

@@ -14,8 +14,7 @@     FutharkExe (..),     getValues,     getValuesBS,-    withValuesFile,-    checkValueTypes,+    valuesAsVars,     compareValues,     checkResult,     testRunReferenceOutput,@@ -57,17 +56,19 @@ import Data.List (foldl') import qualified Data.Map.Strict as M import Data.Maybe+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Void import Futhark.Analysis.Metrics.Type import Futhark.IR.Primitive (floatByteSize, intByteSize)+import qualified Futhark.Script as Script import Futhark.Server import Futhark.Test.Values import Futhark.Test.Values.Parser import Futhark.Util (directoryContents, pmapIO)-import Futhark.Util.Pretty (pretty, prettyText)+import Futhark.Util.Pretty (pretty, prettyOneLine, prettyText, prettyTextOneLine) import Language.Futhark.Prop (primByteSize, primValueType) import Language.Futhark.Syntax (PrimType (..), PrimValue (..)) import System.Directory@@ -147,12 +148,14 @@   }   deriving (Show) --- | Several Values - either literally, or by reference to a file, or--- to be generated on demand.+-- | Several values - either literally, or by reference to a file, or+-- to be generated on demand.  All paths are relative to test program. data Values   = Values [Value]   | InFile FilePath   | GenValues [GenValue]+  | ScriptValues Script.Exp+  | ScriptFile FilePath   deriving (Show)  data GenValue@@ -287,7 +290,10 @@       input <-         if "random" `elem` tags           then parseRandomValues-          else parseValues+          else+            if "script" `elem` tags+              then parseScriptValues+              else parseValues       expr <- parseExpectedResult       return $ TestRun tags input expr i $ desc i input @@ -309,6 +315,10 @@             | otherwise -> s     desc _ (GenValues gens) =       unwords $ map genValueType gens+    desc _ (ScriptValues e) =+      prettyOneLine e+    desc _ (ScriptFile path) =+      path  parseExpectedResult :: Parser (ExpectedResult Success) parseExpectedResult =@@ -326,8 +336,17 @@     -- newlines like ordinary characters, which is what we want.       ThisError s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s) +parseScriptValues :: Parser Values+parseScriptValues =+  choice+    [ ScriptValues <$> braces (Script.parseExp postlexeme),+      ScriptFile . T.unpack <$> (lexstr "@" *> lexeme nextWord)+    ]+  where+    nextWord = takeWhileP Nothing $ not . isSpace+ parseRandomValues :: Parser Values-parseRandomValues = GenValues <$> between (lexstr "{") (lexstr "}") (many parseGenValue)+parseRandomValues = GenValues <$> braces (many parseGenValue)  parseGenValue :: Parser GenValue parseGenValue =@@ -489,64 +508,143 @@       Values {} -> "<values>"       InFile f -> f       GenValues {} -> "<randomly generated>"+      ScriptValues {} -> "<FutharkScript expression>"+      ScriptFile f -> f +readAndDecompress :: FilePath -> IO (Either DecompressError BS.ByteString)+readAndDecompress file = E.try $ do+  s <- BS.readFile file+  E.evaluate $ decompress s+ -- | Extract a pretty representation of some 'Values'.  In the IO -- monad because this might involve reading from a file.  There is no -- guarantee that the resulting byte string yields a readable value.-getValuesBS :: MonadIO m => FutharkExe -> FilePath -> Values -> m BS.ByteString+getValuesBS :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m BS.ByteString getValuesBS _ _ (Values vs) =   return $ BS.fromStrict $ T.encodeUtf8 $ T.unlines $ map prettyText vs getValuesBS _ dir (InFile file) =   case takeExtension file of     ".gz" -> liftIO $ do-      s <- E.try readAndDecompress+      s <- readAndDecompress file'       case s of-        Left e -> fail $ show file ++ ": " ++ show (e :: DecompressError)+        Left e -> fail $ show file ++ ": " ++ show e         Right s' -> return s'     _ -> liftIO $ BS.readFile file'   where     file' = dir </> file-    readAndDecompress = do-      s <- BS.readFile file'-      E.evaluate $ decompress s getValuesBS futhark dir (GenValues gens) =   mconcat <$> mapM (getGenBS futhark dir) gens+getValuesBS _ _ (ScriptValues e) =+  fail $ "Cannot get values from FutharkScript expression: " <> prettyOneLine e+getValuesBS _ _ (ScriptFile f) =+  fail $ "Cannot get values from FutharkScript file: " <> f --- | Evaluate an IO action while the values are available in the--- binary format in a file by some name.  The file will be removed--- after the action is done.-withValuesFile ::-  MonadIO m =>+valueAsVar ::+  (MonadError T.Text m, MonadIO m) =>+  Server ->+  VarName ->+  TypeName ->+  Value ->+  m ()+valueAsVar server v t val = do+  cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do+    BS.hPutStr tmpf_h $ Bin.encode val+    hClose tmpf_h+    cmdRestore server tmpf [(v, t)]++-- Frees the expression on error.+scriptValueAsVars ::+  (MonadError T.Text m, MonadIO m) =>+  Server ->+  [(VarName, TypeName)] ->+  Script.ExpValue ->+  m ()+scriptValueAsVars server names_and_types val+  | vals <- unCompound val,+    length names_and_types == length vals,+    Just loads <- zipWithM f names_and_types vals =+    sequence_ loads+  where+    f (v, t0) (ValueAtom (Script.SValue t1 sval))+      | t0 == t1 =+        Just $ case sval of+          Script.VVar oldname ->+            cmdMaybe $ cmdRename server oldname v+          Script.VVal sval' ->+            valueAsVar server v t0 sval'+    f _ _ = Nothing+scriptValueAsVars server names_and_types val = do+  cmdMaybe $ cmdFree server $ S.toList $ Script.serverVarsInValue val+  throwError $+    "Expected value of type: "+      <> prettyTextOneLine (mkCompound (map snd names_and_types))+      <> "\nBut got value of type:  "+      <> prettyTextOneLine (fmap Script.scriptValueType val)+      <> notes+  where+    notes = mconcat $ mapMaybe note names_and_types+    note (_, t)+      | "(" `T.isPrefixOf` t =+        Just $+          "\nNote: expected type " <> prettyText t <> " is an opaque tuple that cannot be constructed\n"+            <> "in FutharkScript.  Consider using type annotations to give it a proper name."+      | "{" `T.isPrefixOf` t =+        Just $+          "\nNote: expected type " <> prettyText t <> " is an opaque record that cannot be constructed\n"+            <> "in FutharkScript.  Consider using type annotations to give it a proper name."+      | otherwise =+        Nothing++-- | Make the provided 'Values' available as server-side variables.+-- This may involve arbitrary server-side computation.  Error+-- detection... dubious.+valuesAsVars ::+  (MonadError T.Text m, MonadIO m) =>+  Server ->+  [(VarName, TypeName)] ->   FutharkExe ->   FilePath ->   Values ->-  (FilePath -> IO a) ->-  m a-withValuesFile _ dir (InFile file) f-  | takeExtension file /= ".gz" =-    liftIO $ f $ dir </> file-withValuesFile futhark dir vs f =-  liftIO . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do-    mapM_ (BS.hPutStr tmpf_h . Bin.encode) =<< getValues futhark dir vs+  m ()+valuesAsVars server names_and_types _ dir (InFile file)+  | takeExtension file == ".gz" = do+    s <- liftIO $ readAndDecompress $ dir </> file+    case s of+      Left e ->+        throwError $ T.pack $ show file <> ": " <> show e+      Right s' ->+        cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do+          BS.hPutStr tmpf_h s'+          hClose tmpf_h+          cmdRestore server tmpf names_and_types+  | otherwise =+    cmdMaybe $ cmdRestore server (dir </> file) names_and_types+valuesAsVars server names_and_types futhark dir (GenValues gens) = do+  unless (length gens == length names_and_types) $+    throwError "Mismatch between number of expected and generated values."+  gen_fs <- mapM (getGenFile futhark dir) gens+  forM_ (zip gen_fs names_and_types) $ \(file, (v, t)) ->+    cmdMaybe $ cmdRestore server (dir </> file) [(v, t)]+valuesAsVars server names_and_types _ _ (Values vs) = do+  unless (length vs == length names_and_types) $+    throwError "Mismatch between number of expected and provided values."+  cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do+    mapM_ (BS.hPutStr tmpf_h . Bin.encode) vs     hClose tmpf_h-    f tmpf---- | Check that the file contains values of the expected types.-checkValueTypes ::-  (MonadError T.Text m, MonadIO m) => FilePath -> [TypeName] -> m ()-checkValueTypes values_f input_types = do-  maybe_vs <- liftIO $ readValues <$> BS.readFile values_f-  case maybe_vs of-    Nothing ->-      throwError "Invalid input data format."-    Just vs -> do-      let vs_types = map (prettyValueTypeNoDims . valueType) vs-      unless (vs_types == input_types) $-        throwError $-          T.unlines-            [ "Expected input types: " <> T.unwords input_types,-              "Provided input types: " <> T.unwords vs_types-            ]+    cmdRestore server tmpf names_and_types+valuesAsVars server names_and_types _ _ (ScriptValues e) =+  Script.withScriptServer' server $ \server' -> do+    e_v <- Script.evalExp noBuiltin server' e+    scriptValueAsVars server names_and_types e_v+  where+    noBuiltin f _ = do+      throwError $ "Unknown builtin procedure: " <> f+valuesAsVars server names_and_types futhark dir (ScriptFile f) = do+  e <-+    either (throwError . T.pack . errorBundlePretty) pure+      . parse (Script.parseExp space) f+      =<< liftIO (T.readFile (dir </> f))+  valuesAsVars server names_and_types futhark dir (ScriptValues e)  -- | There is a risk of race conditions when multiple programs have -- identical 'GenValues'.  In such cases, multiple threads in 'futhark@@ -558,8 +656,8 @@ -- approach here seems robust enough for now, but certainly it could -- be made even better.  The race condition that remains should mostly -- result in duplicate work, not crashes or data corruption.-getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString-getGenBS futhark dir gen = do+getGenFile :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m FilePath+getGenFile futhark dir gen = do   liftIO $ createDirectoryIfMissing True $ dir </> "data"   exists_and_proper_size <-     liftIO $@@ -575,9 +673,12 @@         hClose h -- We will be writing and reading this ourselves.         SBS.writeFile tmpfile s         renameFile tmpfile $ dir </> file-  getValuesBS futhark dir $ InFile file+  pure file   where     file = "data" </> genFileName gen++getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString+getGenBS futhark dir gen = liftIO . BS.readFile . (dir </>) =<< getGenFile futhark dir gen  genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString genValues (FutharkExe futhark) gens = do