futhark 0.22.6 → 0.22.7

raw patch · 62 files changed

+922/−603 lines, 62 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/man/futhark-literate.rst +42/−1
• futhark.cabal +1/−1
• rts/c/context.h +48/−0
• rts/c/context_prototypes.h +10/−1
• rts/c/cuda.h +12/−17
• rts/c/free_list.h +29/−14
• rts/c/opencl.h +25/−23
• src/Futhark/Actions.hs +8/−10
• src/Futhark/Analysis/Interference.hs +7/−5
• src/Futhark/Analysis/MemAlias.hs +15/−10
• src/Futhark/Analysis/Metrics.hs +2/−1
• src/Futhark/Bench.hs +4/−3
• src/Futhark/CLI/Autotune.hs +2/−2
• src/Futhark/CLI/Bench.hs +2/−2
• src/Futhark/CLI/Dev.hs +4/−1
• src/Futhark/CLI/Literate.hs +145/−4
• src/Futhark/CLI/Main.hs +2/−3
• src/Futhark/CLI/Test.hs +8/−8
• src/Futhark/CodeGen/Backends/CCUDA.hs +5/−4
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +11/−13
• src/Futhark/CodeGen/Backends/COpenCL.hs +5/−4
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +9/−11
• src/Futhark/CodeGen/Backends/GenericC.hs +4/−4
• src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs +9/−18
• src/Futhark/CodeGen/Backends/GenericC/Monad.hs +34/−20
• src/Futhark/CodeGen/Backends/GenericC/Server.hs +5/−5
• src/Futhark/CodeGen/Backends/GenericC/Types.hs +46/−42
• src/Futhark/CodeGen/Backends/GenericPython.hs +61/−67
• src/Futhark/CodeGen/Backends/GenericPython/AST.hs +1/−1
• src/Futhark/CodeGen/Backends/GenericPython/Options.hs +7/−10
• src/Futhark/CodeGen/Backends/GenericWASM.hs +5/−4
• src/Futhark/CodeGen/Backends/MulticoreC.hs +4/−4
• src/Futhark/CodeGen/Backends/MulticoreISPC.hs +3/−3
• src/Futhark/CodeGen/Backends/PyOpenCL.hs +9/−9
• src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +7/−7
• src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +3/−4
• src/Futhark/CodeGen/Backends/SimpleRep.hs +16/−14
• src/Futhark/CodeGen/ImpCode.hs +1/−1
• src/Futhark/CodeGen/ImpGen.hs +4/−7
• src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs +5/−5
• src/Futhark/CodeGen/ImpGen/Multicore.hs +65/−30
• src/Futhark/Compiler/Program.hs +24/−19
• src/Futhark/IR/Parse.hs +3/−3
• src/Futhark/IR/SOACS/Simplify.hs +13/−12
• src/Futhark/IR/Syntax/Core.hs +2/−2
• src/Futhark/IR/TypeCheck.hs +1/−1
• src/Futhark/Internalise/Entry.hs +7/−8
• src/Futhark/LSP/Handlers.hs +25/−16
• src/Futhark/Optimise/Simplify/Rules.hs +3/−9
• src/Futhark/Optimise/Simplify/Rules/Index.hs +2/−2
• src/Futhark/Pkg/Info.hs +3/−3
• src/Futhark/Test.hs +3/−3
• src/Futhark/Util.hs +21/−6
• src/Futhark/Util/Options.hs +5/−4
• src/Futhark/Version.hs +9/−10
• src/Language/Futhark/Core.hs +2/−1
• src/Language/Futhark/Parser/Lexer.x +10/−19
• src/Language/Futhark/Parser/Lexer/Tokens.hs +2/−5
• src/Language/Futhark/Parser/Lexer/Wrapper.hs +4/−0
• src/Language/Futhark/Parser/Parser.y +86/−83
• src/Language/Futhark/Primitive.hs +4/−3
• src/Language/Futhark/TypeChecker/Terms.hs +8/−1

@@ -32,7 +32,7 @@ **Warning:** Do not run untrusted programs.  See SAFETY below.  Image directives and builtin functions shell out to ``convert`` (from-ImageMagick).  Video generation uses ``ffmpeg``.+ImageMagick).  Video and audio generation uses ``ffmpeg``.  For an input file ``foo.fut``, all generated files will be in a directory named ``foo-img``.  A ``file`` parameter passed to a@@ -193,6 +193,47 @@    Use ``set term png size width,height`` to change the size to   ``width`` by ``height`` pixels.++* ``> :audio e[; parameters...]``++  Creates a sound-file from ``e``.  The optional parameters are lines of the+  form *key:value*:++  * ``sampling_frequency: <int>``++    The sampling frequency (in Hz) of the input.  Defaults to ``44100``.++  * ``codec: <name>``++    The codec of the output.  Defaults to ``wav``. Other common options include+    ``mp3``, ``flac``, ``ogg`` and ``opus``.++  The expression ``e`` must have one of the following types:++  * ``[]i8`` and ``[]u8``++    Interpreted as PCM signed/unsigned 8-bit audio.++  * ``[]i16`` and ``[]u16``++    Interpreted as PCM signed/unsigned 16-bit audio.++  * ``[]i32`` and ``[]u32``++    Interpreted as PCM signed/unsigned 32-bit audio.++  * ``[]f32`` and ``[]f64``++    Interpreted as PCM signed/unsigned 32/64 bit floating-point audio. Should+    only contain values between ``-1.0`` and ``1.0``.++  For each type of input, it is also possible to give expressions with a+  two-dimensional type instead, e.g. ``[][]f32``.  These expressions are+  interpreted as an array of channels, making it possible to do stereo audio by+  returning e.g. ``[2][]f32``.  For stereo output, the first row is the left+  channel and the second row is the right channel.  This functionality uses the+  amerge filter from ffmpeg, so consult the documentation there for additional+  information.  FUTHARKSCRIPT =============

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.22.6+version:        0.22.7 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to

@@ -38,4 +38,52 @@   } } +static void free_all_in_free_list(struct futhark_context* ctx) {+  fl_mem mem;+  free_list_pack(&ctx->free_list);+  while (free_list_first(&ctx->free_list, (fl_mem*)&mem) == 0) {+    free((void*)mem);+  }+}++static int is_small_alloc(size_t size) {+  return size < 1024*1024;+}++static void host_alloc(struct futhark_context* ctx,+                       size_t size, const char* tag, size_t* size_out, void** mem_out) {+  if (is_small_alloc(size) || free_list_find(&ctx->free_list, size, tag, size_out, (fl_mem*)mem_out) != 0) {+    *size_out = size;+    *mem_out = malloc(size);+  }+}++static void host_free(struct futhark_context* ctx,+                      size_t size, const char* tag, void* mem) {+  // Small allocations are handled by malloc()s own free list.  The+  // threshold here is kind of arbitrary, but seems to work OK.+  // Larger allocations are mmap()ed/munmapped() every time, which is+  // very slow, and Futhark programs tend to use a few very large+  // allocations.+  if (is_small_alloc(size)) {+    free(mem);+  } else {+    free_list_insert(&ctx->free_list, size, (fl_mem)mem, tag);+  }+}++static void context_setup(struct futhark_context *ctx) {+  create_lock(&ctx->error_lock);+  create_lock(&ctx->lock);+  free_list_init(&ctx->free_list);+}++static void context_teardown(struct futhark_context *ctx) {+  free_constants(ctx);+  free_all_in_free_list(ctx);+  free_list_destroy(&ctx->free_list);+  free_lock(&ctx->lock);+  free_lock(&ctx->error_lock);+}+ // End of context.h

@@ -1,11 +1,20 @@ // Start of context_prototypes.h //-// Prototypes for the functions in prototypes.h that need to be+// Prototypes for the functions in context.h that need to be // available very early.  struct futhark_context_config; struct futhark_context;  static void set_error(struct futhark_context* ctx, char *error);++// These are called in context new/free functions and contain shared setup.+static void context_setup(struct futhark_context *ctx);+static void context_teardown(struct futhark_context *ctx);++// Allocate host memory.  Must be freed with host_free().+static void host_alloc(struct futhark_context* ctx, size_t size, const char* tag, size_t* size_out, void** mem_out);+// Allocate memory allocated with host_alloc().+static void host_free(struct futhark_context* ctx, size_t size, const char* tag, void* mem);  // End of of context_prototypes.h

@@ -697,14 +697,14 @@ }  static CUresult cuda_alloc(struct cuda_context *ctx, FILE *log,-                           size_t min_size, const char *tag, CUdeviceptr *mem_out) {+                           size_t min_size, const char *tag,+                           CUdeviceptr *mem_out, size_t *size_out) {   if (min_size < sizeof(int)) {     min_size = sizeof(int);   } -  size_t size;-  if (free_list_find(&ctx->free_list, min_size, tag, &size, mem_out) == 0) {-    if (size >= min_size) {+  if (free_list_find(&ctx->free_list, min_size, tag, size_out, (fl_mem*)mem_out) == 0) {+    if (*size_out >= min_size) {       if (ctx->cfg.debugging) {         fprintf(log, "No need to allocate: Found a block in the free list.\n");       }@@ -721,6 +721,8 @@     }   } +  *size_out = min_size;+   if (ctx->cfg.debugging) {     fprintf(log, "Actually allocating the desired block.\n");   }@@ -728,7 +730,7 @@   CUresult res = cuMemAlloc(mem_out, min_size);   while (res == CUDA_ERROR_OUT_OF_MEMORY) {     CUdeviceptr mem;-    if (free_list_first(&ctx->free_list, &mem) == 0) {+    if (free_list_first(&ctx->free_list, (fl_mem*)&mem) == 0) {       res = cuMemFree(mem);       if (res != CUDA_SUCCESS) {         return res;@@ -742,23 +744,16 @@   return res; } -static CUresult cuda_free(struct cuda_context *ctx, CUdeviceptr mem,-                          const char *tag) {-  size_t size;-  CUdeviceptr existing_mem;--  CUresult res = cuMemGetAddressRange(NULL, &size, mem);-  if (res == CUDA_SUCCESS) {-    free_list_insert(&ctx->free_list, size, mem, tag);-  }--  return res;+static CUresult cuda_free(struct cuda_context *ctx,+                          CUdeviceptr mem, size_t size, const char *tag) {+  free_list_insert(&ctx->free_list, size, (fl_mem)mem, tag);+  return CUDA_SUCCESS; }  static CUresult cuda_free_all(struct cuda_context *ctx) {   CUdeviceptr mem;   free_list_pack(&ctx->free_list);-  while (free_list_first(&ctx->free_list, &mem) == 0) {+  while (free_list_first(&ctx->free_list, (fl_mem*)&mem) == 0) {     CUresult res = cuMemFree(mem);     if (res != CUDA_SUCCESS) {       return res;

@@ -1,19 +1,22 @@ // Start of free_list.h. +typedef uintptr_t fl_mem;+ // An entry in the free list.  May be invalid, to avoid having to // deallocate entries as soon as they are removed.  There is also a // tag, to help with memory reuse. struct free_list_entry {   size_t size;-  fl_mem_t mem;+  fl_mem mem;   const char *tag;   unsigned char valid; };  struct free_list {-  struct free_list_entry *entries;        // Pointer to entries.-  int capacity;                           // Number of entries.-  int used;                               // Number of valid entries.+  struct free_list_entry *entries; // Pointer to entries.+  int capacity;                    // Number of entries.+  int used;                        // Number of valid entries.+  lock_t lock;                     // Thread safety. };  static void free_list_init(struct free_list *l) {@@ -23,10 +26,12 @@   for (int i = 0; i < l->capacity; i++) {     l->entries[i].valid = 0;   }+  create_lock(&l->lock); }  // Remove invalid entries from the free list. static void free_list_pack(struct free_list *l) {+  lock_lock(&l->lock);   int p = 0;   for (int i = 0; i < l->capacity; i++) {     if (l->entries[i].valid) {@@ -46,13 +51,16 @@   }   l->entries = realloc(l->entries, p * sizeof(struct free_list_entry));   l->capacity = p;+  lock_unlock(&l->lock); }  static void free_list_destroy(struct free_list *l) {   assert(l->used == 0);   free(l->entries);+  free_lock(&l->lock); } +// Not part of the interface, so no locking. static int free_list_find_invalid(struct free_list *l) {   int i;   for (i = 0; i < l->capacity; i++) {@@ -63,7 +71,8 @@   return i; } -static void free_list_insert(struct free_list *l, size_t size, fl_mem_t mem, const char *tag) {+static void free_list_insert(struct free_list *l, size_t size, fl_mem mem, const char *tag) {+  lock_lock(&l->lock);   int i = free_list_find_invalid(l);    if (i == l->capacity) {@@ -83,10 +92,11 @@   l->entries[i].tag = tag;    l->used++;+  lock_unlock(&l->lock); }  // Determine whether this entry in the free list is acceptable for-// satisfying the request.+// satisfying the request.  Not public, so no locking. static bool free_list_acceptable(size_t size, const char* tag, struct free_list_entry *entry) {   // We check not just the hard requirement (is the entry acceptable   // and big enough?) but also put a cap on how much wasted space@@ -130,9 +140,11 @@ // does not exist, another memory block with exactly the desired size. // Returns 0 on success. static int free_list_find(struct free_list *l, size_t size, const char *tag,-                          size_t *size_out, fl_mem_t *mem_out) {+                          size_t *size_out, fl_mem *mem_out) {+  lock_lock(&l->lock);   int size_match = -1;   int i;+  int ret = 1;   for (i = 0; i < l->capacity; i++) {     if (free_list_acceptable(size, tag, &l->entries[i]) &&         (size_match < 0 || l->entries[i].size < l->entries[size_match].size)) {@@ -147,25 +159,28 @@     *size_out = l->entries[size_match].size;     *mem_out = l->entries[size_match].mem;     l->used--;-    return 0;-  } else {-    return 1;+    ret = 0;   }+  lock_unlock(&l->lock);+  return ret; }  // Remove the first block in the free list.  Returns 0 if a block was // removed, and nonzero if the free list was already empty.-static int free_list_first(struct free_list *l, fl_mem_t *mem_out) {+static int free_list_first(struct free_list *l, fl_mem *mem_out) {+  lock_lock(&l->lock);+  int ret = 1;   for (int i = 0; i < l->capacity; i++) {     if (l->entries[i].valid) {       l->entries[i].valid = 0;       *mem_out = l->entries[i].mem;       l->used--;-      return 0;+      ret = 0;+      break;     }   }--  return 1;+  lock_unlock(&l->lock);+  return ret; }  // End of free_list.h.

@@ -964,34 +964,37 @@ }  static int opencl_alloc(struct opencl_context *ctx, FILE *log,-                        size_t min_size, const char *tag, cl_mem *mem_out) {+                        size_t min_size, const char *tag,+                        cl_mem *mem_out, size_t *size_out) {   (void)tag;   if (min_size < sizeof(int)) {     min_size = sizeof(int);   } -  size_t size;--  if (free_list_find(&ctx->free_list, min_size, tag, &size, mem_out) == 0) {+  cl_mem* memptr;+  if (free_list_find(&ctx->free_list, min_size, tag, size_out, (fl_mem*)&memptr) == 0) {     // Successfully found a free block.  Is it big enough?-    if (size >= min_size) {+    if (*size_out >= min_size) {       if (ctx->cfg.debugging) {         fprintf(log, "No need to allocate: Found a block in the free list.\n");       }-+      *mem_out = *memptr;+      free(memptr);       return CL_SUCCESS;     } else {       if (ctx->cfg.debugging) {         fprintf(log, "Found a free block, but it was too small.\n");       }--      int error = clReleaseMemObject(*mem_out);+      int error = clReleaseMemObject(*memptr);+      free(*memptr);       if (error != CL_SUCCESS) {         return error;       }     }   } +  *size_out = min_size;+   // We have to allocate a new block from the driver.  If the   // allocation does not succeed, then we might be in an out-of-memory   // situation.  We now start freeing things from the free list until@@ -1010,8 +1013,10 @@     if (ctx->cfg.debugging) {       fprintf(log, "Out of OpenCL memory: releasing entry from the free list...\n");     }-    cl_mem mem;-    if (free_list_first(&ctx->free_list, &mem) == 0) {+    cl_mem* memptr;+    if (free_list_first(&ctx->free_list, (fl_mem*)&memptr) == 0) {+      cl_mem mem = *memptr;+      free(memptr);       error = clReleaseMemObject(mem);       if (error != CL_SUCCESS) {         return error;@@ -1025,23 +1030,20 @@   return error; } -static int opencl_free(struct opencl_context *ctx, cl_mem mem, const char *tag) {-  size_t size;-  cl_mem existing_mem;--  int error = clGetMemObjectInfo(mem, CL_MEM_SIZE, sizeof(size_t), &size, NULL);--  if (error == CL_SUCCESS) {-    free_list_insert(&ctx->free_list, size, mem, tag);-  }--  return error;+static int opencl_free(struct opencl_context *ctx,+                       cl_mem mem, size_t size, const char *tag) {+  cl_mem* memptr = malloc(sizeof(cl_mem));+  *memptr = mem;+  free_list_insert(&ctx->free_list, size, (fl_mem)memptr, tag);+  return CL_SUCCESS; }  static int opencl_free_all(struct opencl_context *ctx) {-  cl_mem mem;   free_list_pack(&ctx->free_list);-  while (free_list_first(&ctx->free_list, &mem) == 0) {+  cl_mem* memptr;+  while (free_list_first(&ctx->free_list, (fl_mem*)&memptr) == 0) {+    cl_mem mem = *memptr;+    free(memptr);     int error = clReleaseMemObject(mem);     if (error != CL_SUCCESS) {       return error;

@@ -190,7 +190,7 @@  -- Lines that we prepend (in comments) to generated code. headerLines :: [T.Text]-headerLines = T.lines $ "Generated by Futhark " <> T.pack versionString+headerLines = T.lines $ "Generated by Futhark " <> versionString  cHeaderLines :: [T.Text] cHeaderLines = map ("// " <>) headerLines@@ -294,7 +294,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ SequentialC.compileProg (T.pack versionString) prog+      cprog <- handleWarnings fcfg $ SequentialC.compileProg versionString prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -322,7 +322,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ COpenCL.compileProg (T.pack versionString) prog+      cprog <- handleWarnings fcfg $ COpenCL.compileProg versionString prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -357,7 +357,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ CCUDA.compileProg (T.pack versionString) prog+      cprog <- handleWarnings fcfg $ CCUDA.compileProg versionString prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -389,7 +389,7 @@     }   where     helper prog = do-      cprog <- handleWarnings fcfg $ MulticoreC.compileProg (T.pack versionString) prog+      cprog <- handleWarnings fcfg $ MulticoreC.compileProg versionString prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"           jsonpath = outpath `addExtension` "json"@@ -422,7 +422,7 @@           jsonpath = outpath `addExtension` "json"           ispcpath = outpath `addExtension` "kernels.ispc"           ispcextension = "_ispc"-      (cprog, ispc) <- handleWarnings fcfg $ MulticoreISPC.compileProg (T.pack versionString) prog+      (cprog, ispc) <- handleWarnings fcfg $ MulticoreISPC.compileProg versionString prog       case mode of         ToLibrary -> do           let (header, impl, manifest) = MulticoreC.asLibrary cprog@@ -530,8 +530,7 @@   where     helper prog = do       (cprog, jsprog, exps) <--        handleWarnings fcfg $-          SequentialWASM.compileProg (T.pack versionString) prog+        handleWarnings fcfg $ SequentialWASM.compileProg versionString prog       case mode of         ToLibrary -> do           writeLibs cprog jsprog@@ -564,8 +563,7 @@   where     helper prog = do       (cprog, jsprog, exps) <--        handleWarnings fcfg $-          MulticoreWASM.compileProg (T.pack versionString) prog+        handleWarnings fcfg $ MulticoreWASM.compileProg versionString prog        case mode of         ToLibrary -> do

@@ -210,15 +210,17 @@   analyseBody lumap inuse body  analyseProgGPU :: Prog GPUMem -> Graph VName-analyseProgGPU prog =-  applyAliases (MemAlias.analyzeGPUMem prog) $-    onConsts (progConsts prog) <> foldMap onFun (progFuns prog)+analyseProgGPU prog = onConsts (progConsts prog) <> foldMap onFun (progFuns prog)   where+    (consts_aliases, funs_aliases) = MemAlias.analyzeGPUMem prog     lumap = LastUse.analyseGPUMem prog     onFun f =-      runReader (analyseGPU lumap $ bodyStms $ funDefBody f) $ scopeOf f+      applyAliases (fromMaybe mempty $ M.lookup (funDefName f) funs_aliases) $+        runReader (analyseGPU lumap $ bodyStms $ funDefBody f) $+          scopeOf f     onConsts stms =-      runReader (analyseGPU lumap stms) (mempty :: Scope GPUMem)+      applyAliases consts_aliases $+        runReader (analyseGPU lumap stms) (mempty :: Scope GPUMem)  applyAliases :: MemAlias.MemAliases -> Graph VName -> Graph VName applyAliases aliases =

@@ -114,12 +114,13 @@ analyzeStms =   flip $ foldM analyzeStm -analyzeFun :: (Mem rep inner, LetDec rep ~ LetDecMem) => FunDef rep -> MemAliasesM inner MemAliases+analyzeFun :: (Mem rep inner, LetDec rep ~ LetDecMem) => FunDef rep -> MemAliasesM inner (Name, MemAliases) analyzeFun f =   funDefParams f     & mapMaybe justMem     & mconcat     & analyzeStms (bodyStms $ funDefBody f)+    <&> (funDefName f,)   where     justMem (Param _ v (MemMem _)) = Just $ singleton v mempty     justMem _ = Nothing@@ -135,18 +136,22 @@     m     <> ma -analyzeSeqMem :: Prog SeqMem -> MemAliases+-- | Produce aliases for constants and for each function.+analyzeSeqMem :: Prog SeqMem -> (MemAliases, M.Map Name MemAliases) analyzeSeqMem prog = completeBijection $ runReader (analyze prog) $ Env $ \x _ -> pure x -analyzeGPUMem :: Prog GPUMem -> MemAliases+-- | Produce aliases for constants and for each function.+analyzeGPUMem :: Prog GPUMem -> (MemAliases, M.Map Name MemAliases) analyzeGPUMem prog = completeBijection $ runReader (analyze prog) $ Env analyzeHostOp -analyze :: (Mem rep inner, LetDec rep ~ LetDecMem) => Prog rep -> MemAliasesM inner MemAliases+analyze :: (Mem rep inner, LetDec rep ~ LetDecMem) => Prog rep -> MemAliasesM inner (MemAliases, M.Map Name MemAliases) analyze prog =-  progFuns prog-    & foldM (\m f -> (<>) m <$> analyzeFun f) (MemAliases mempty)-    <&> fixPoint transitiveClosure+  (,)+    <$> (progConsts prog & flip analyzeStms mempty <&> fixPoint transitiveClosure)+    <*> (progFuns prog & mapM analyzeFun <&> M.fromList <&> M.map (fixPoint transitiveClosure)) -completeBijection :: MemAliases -> MemAliases-completeBijection ma@(MemAliases m) =-  M.foldMapWithKey (\k ns -> foldMap (`singleton` oneName k) (namesToList ns)) m <> ma+completeBijection :: (MemAliases, M.Map Name MemAliases) -> (MemAliases, M.Map Name MemAliases)+completeBijection (a, bs) = (f a, fmap f bs)+  where+    f ma@(MemAliases m) =+      M.foldMapWithKey (\k ns -> foldMap (`singleton` oneName k) (namesToList ns)) m <> ma

@@ -22,6 +22,7 @@ import Data.Text qualified as T import Futhark.Analysis.Metrics.Type import Futhark.IR+import Futhark.Util (showText)  -- | Compute the metrics for some operation. class OpMetrics op where@@ -109,7 +110,7 @@ expMetrics (Match _ cases defbody _) =   inside "Match" $ do     forM_ (zip [0 ..] cases) $ \(i, c) ->-      inside (T.pack (show (i :: Int))) $ bodyMetrics $ caseBody c+      inside (showText (i :: Int)) $ bodyMetrics $ caseBody c     inside "default" $ bodyMetrics defbody expMetrics Apply {} =   seen "Apply"

@@ -30,6 +30,7 @@ import Data.Vector.Unboxed qualified as U import Futhark.Server import Futhark.Test+import Futhark.Util (showText) import Statistics.Autocorrelation (autocorrelation) import Statistics.Sample (fastStdDev, mean) import System.Exit@@ -276,8 +277,8 @@ benchmarkDataset server opts futhark program entry input_spec expected_spec ref_out = runExceptT $ do   output_types <- cmdEither $ cmdOutputs server entry   input_types <- cmdEither $ cmdInputs server entry-  let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types - 1]]-      ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types - 1]]+  let outs = ["out" <> showText i | i <- [0 .. length output_types - 1]]+      ins = ["in" <> showText i | i <- [0 .. length input_types - 1]]    cmdMaybe . liftIO $ cmdClear server @@ -301,7 +302,7 @@         case mapMaybe runtime call_lines of           [call_runtime] -> pure (RunResult call_runtime, call_lines)           [] -> throwError "Could not find runtime in output."-          ls -> throwError $ "Ambiguous runtimes: " <> T.pack (show ls)+          ls -> throwError $ "Ambiguous runtimes: " <> showText ls    maybe_call_logs <- liftIO . timeout (runTimeout opts * 1000000) . runExceptT $ do     -- First one uncounted warmup run.

@@ -13,7 +13,7 @@ import Futhark.Bench import Futhark.Server import Futhark.Test-import Futhark.Util (maxinum)+import Futhark.Util (maxinum, showText) import Futhark.Util.Options import System.Directory import System.Environment (getExecutablePath)@@ -104,7 +104,7 @@ setTuningParam :: Server -> String -> Int -> IO () setTuningParam server name val =   either (error . T.unpack . T.unlines . failureMsg) (const $ pure ())-    =<< cmdSetTuningParam server (T.pack name) (T.pack (show val))+    =<< cmdSetTuningParam server (T.pack name) (showText val)  setTuningParams :: Server -> Path -> IO () setTuningParams server = mapM_ (uncurry $ setTuningParam server)

@@ -21,7 +21,7 @@ import Futhark.Bench import Futhark.Server import Futhark.Test-import Futhark.Util (atMostChars, fancyTerminal, pmapIO)+import Futhark.Util (atMostChars, fancyTerminal, pmapIO, showText) import Futhark.Util.Options import Futhark.Util.Pretty (AnsiStyle, Color (..), annotate, bold, color, line, pretty, prettyText, putDoc) import Futhark.Util.ProgressBar@@ -216,7 +216,7 @@     onError :: SomeException -> IO (Maybe a)     onError e = do       putBoldRedLn $ "\nFailed to run " <> T.pack program-      putRedLn $ T.pack $ show e+      putRedLn $ showText e       pure Nothing  -- Truncate dataset name display after this many characters.

@@ -769,10 +769,13 @@           let (base, ext) = splitExtension file                readCore parse construct = do+                logMsg $ "Reading " <> file <> "..."                 input <- liftIO $ T.readFile file+                logMsg ("Parsing..." :: T.Text)                 case parse file input of                   Left err -> externalErrorS $ T.unpack err-                  Right prog ->+                  Right prog -> do+                    logMsg ("Typechecking..." :: T.Text)                     case checkProg $ Alias.aliasAnalysis prog of                       Left err -> externalErrorS $ show err                       Right () -> runPolyPasses config base $ construct prog

@@ -34,6 +34,7 @@     hashText,     nubOrd,     runProgramWithExitCode,+    showText,   ) import Futhark.Util.Options import Futhark.Util.Pretty (prettyText, prettyTextOneLine)@@ -83,6 +84,19 @@       videoFile = Nothing     } +data AudioParams = AudioParams+  { audioSamplingFrequency :: Maybe Int,+    audioCodec :: Maybe T.Text+  }+  deriving (Show)++defaultAudioParams :: AudioParams+defaultAudioParams =+  AudioParams+    { audioSamplingFrequency = Nothing,+      audioCodec = Nothing+    }+ data Directive   = DirectiveRes Exp   | DirectiveBrief Directive@@ -91,6 +105,7 @@   | DirectivePlot Exp (Maybe (Int, Int))   | DirectiveGnuplot Exp T.Text   | DirectiveVideo Exp VideoParams+  | DirectiveAudio Exp AudioParams   deriving (Show)  varsInDirective :: Directive -> S.Set EntryName@@ -101,6 +116,7 @@ varsInDirective (DirectivePlot e _) = varsInExp e varsInDirective (DirectiveGnuplot e _) = varsInExp e varsInDirective (DirectiveVideo e _) = varsInExp e+varsInDirective (DirectiveAudio e _) = varsInExp e  pprDirective :: Bool -> Directive -> PP.Doc a pprDirective _ (DirectiveRes e) =@@ -148,6 +164,18 @@     p s f pretty = do       x <- f params       Just $ s <> ": " <> pretty x+pprDirective _ (DirectiveAudio e params) =+  ("> :audio " <> PP.pretty e)+    <> if null params' then mempty else ";" <> PP.hardline <> PP.stack params'+  where+    params' =+      catMaybes+        [ p "sampling_frequency" audioSamplingFrequency PP.pretty,+          p "codec" audioCodec PP.pretty+        ]+    p s f pretty = do+      x <- f params+      Just $ s <> ": " <> pretty x  instance PP.Pretty Directive where   pretty = pprDirective True@@ -272,6 +300,28 @@       s <- lexeme $ takeWhileP Nothing (not . isSpace)       pure params {videoFormat = Just s} +parseAudioParams :: Parser AudioParams+parseAudioParams =+  fmap (fromMaybe defaultAudioParams) $+    optional $+      ";" *> hspace *> eol *> "-- " *> parseParams defaultAudioParams+  where+    parseParams params =+      choice+        [ choice+            [pSamplingFrequency params, pCodec params]+            >>= parseParams,+          pure params+        ]+    pSamplingFrequency params = do+      token "sampling_frequency:"+      hz <- parseInt+      pure params {audioSamplingFrequency = Just hz}+    pCodec params = do+      token "codec:"+      s <- lexeme $ takeWhileP Nothing (not . isSpace)+      pure params {audioCodec = Just s}+ atStartOfLine :: Parser () atStartOfLine = do   col <- sourceColumn <$> getSourcePos@@ -332,6 +382,11 @@             $> DirectiveVideo             <*> parseExp postlexeme             <*> parseVideoParams+            <* eol,+          directiveName "audio"+            $> DirectiveAudio+            <*> parseExp postlexeme+            <*> parseAudioParams             <* eol         ]     directiveName s = try $ token (":" <> s)@@ -456,14 +511,14 @@   res <- liftIO $ runProgramWithExitCode prog options $ T.encodeUtf8 input   case res of     Left err ->-      throwError $ prog' <> " failed: " <> T.pack (show err)+      throwError $ prog' <> " failed: " <> showText err     Right (ExitSuccess, stdout_t, _) ->       pure $ T.pack stdout_t     Right (ExitFailure code', _, stderr_t) ->       throwError $         prog'           <> " failed with exit code "-          <> T.pack (show code')+          <> showText code'           <> " and stderr:\n"           <> T.pack stderr_t   where@@ -520,7 +575,7 @@   res <- liftIO $ BMP.readBMP bmpfile   case res of     Left err ->-      throwError $ "Failed to read BMP:\n" <> T.pack (show err)+      throwError $ "Failed to read BMP:\n" <> showText err     Right bmp -> do       let bmp_bs = BMP.unpackBMPToRGBA32 bmp           (w, h) = BMP.bmpDimensions bmp@@ -698,7 +753,7 @@       [x, y] <- plottable v       Just [x, y] -    tag (Nothing, xys) j = ("data" <> T.pack (show (j :: Int)), xys)+    tag (Nothing, xys) j = ("data" <> showText (j :: Int), xys)     tag (Just f, xys) _ = (f, xys)      plotWith xys pngfile =@@ -858,6 +913,92 @@           void $ system "ffmpeg" ["-i", webmfile, videofile] mempty       | otherwise =           liftIO $ copyFile webmfile videofile++--+processDirective env (DirectiveAudio e params) = do+  fmap imgBlock . newFile env (Nothing, "output." <> T.unpack output_format) $+    \audiofile -> do+      withTempDir $ \dir -> do+        maybe_v <- evalExpToGround literateBuiltin (envServer env) e+        maybe_raw_files <- toRawFiles dir maybe_v+        case maybe_raw_files of+          (input_format, raw_files) -> do+            void $+              system+                "ffmpeg"+                ( concatMap+                    ( \raw_file ->+                        [ "-f",+                          input_format,+                          "-ar",+                          show sampling_frequency,+                          "-i",+                          raw_file+                        ]+                    )+                    raw_files+                    ++ [ "-f",+                         T.unpack output_format,+                         "-filter_complex",+                         concatMap+                           (\i -> "[" <> show i <> ":a]")+                           [0 .. length raw_files - 1]+                           <> "amerge=inputs="+                           <> show (length raw_files)+                           <> "[a]",+                         "-map",+                         "[a]",+                         audiofile+                       ]+                )+                mempty+  where+    writeRaw dir name v = do+      let rawfile = dir </> name+      let Just bytes = toBytes v+      liftIO $ LBS.writeFile rawfile $ LBS.fromStrict bytes++    toRawFiles dir (Right (ValueAtom v))+      | length (valueShape v) == 1,+        Just input_format <- toFfmpegFormat v = do+          writeRaw dir "raw.pcm" v+          pure (input_format, [dir </> "raw.pcm"])+      | length (valueShape v) == 2,+        Just input_format <- toFfmpegFormat v = do+          (input_format,)+            <$> zipWithM+              ( \v' i -> do+                  let file_name = "raw-" <> show i <> ".pcm"+                  writeRaw dir file_name v'+                  pure $ dir </> file_name+              )+              (valueElems v)+              [0 :: Int ..]+    toRawFiles _ v = nope $ fmap (fmap valueType) v++    toFfmpegFormat I8Value {} = Just "s8"+    toFfmpegFormat U8Value {} = Just "u8"+    toFfmpegFormat I16Value {} = Just "s16le"+    toFfmpegFormat U16Value {} = Just "u16le"+    toFfmpegFormat I32Value {} = Just "s32le"+    toFfmpegFormat U32Value {} = Just "u32le"+    toFfmpegFormat F32Value {} = Just "f32le"+    toFfmpegFormat F64Value {} = Just "f64le"+    toFfmpegFormat _ = Nothing++    toBytes (I8Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (U8Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (I16Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (U16Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (I32Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (U32Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (F32Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes (F64Value _ bytes) = Just $ SVec.vectorToByteString bytes+    toBytes _ = Nothing++    output_format = fromMaybe "wav" $ audioCodec params+    sampling_frequency = fromMaybe 44100 $ audioSamplingFrequency params+    nope _ = throwError "Cannot create audio from value"  -- Did this script block succeed or fail? data Failure = Failure | Success

@@ -4,7 +4,6 @@ import Control.Exception import Data.List (sortOn) import Data.Maybe-import Data.Text qualified as T import Data.Text.IO qualified as T import Futhark.CLI.Autotune qualified as Autotune import Futhark.CLI.Bench qualified as Bench@@ -32,7 +31,7 @@ import Futhark.CLI.Test qualified as Test import Futhark.CLI.WASM qualified as WASM import Futhark.Error-import Futhark.Util (maxinum)+import Futhark.Util (maxinum, showText) import Futhark.Util.Options import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Exception (IOErrorType (..), IOException (..))@@ -123,7 +122,7 @@       | otherwise = do           T.hPutStrLn stderr "Internal compiler error (unhandled IO exception)."           T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues"-          T.hPutStrLn stderr $ T.pack $ show e+          T.hPutStrLn stderr $ showText e           exitWith $ ExitFailure 1      onIOException :: IOException -> IO ()

@@ -18,7 +18,7 @@ import Futhark.Analysis.Metrics.Type import Futhark.Server import Futhark.Test-import Futhark.Util (atMostChars, fancyTerminal)+import Futhark.Util (atMostChars, fancyTerminal, showText) import Futhark.Util.Options import Futhark.Util.Pretty (annotate, bold, hardline, pretty, putDoc, vsep) import Futhark.Util.Table@@ -184,7 +184,7 @@                 name                   <> maybePipeline pipeline                   <> " should have occurred "-                  <> T.pack (show expected_occurences)+                  <> showText expected_occurences                   <> " times, but did not occur at all in optimised program."         Just actual_occurences           | expected_occurences /= actual_occurences ->@@ -192,9 +192,9 @@                 name                   <> maybePipeline pipeline                   <> " should have occurred "-                  <> T.pack (show expected_occurences)+                  <> showText expected_occurences                   <> " times, but occurred "-                  <> T.pack (show actual_occurences)+                  <> showText actual_occurences                   <> " times."         _ -> pure () @@ -312,8 +312,8 @@     Left (CmdFailure _ err) ->       pure [Failure err]     Right (output_types', input_types') -> do-      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]]+      let outs = ["out" <> showText i | i <- [0 .. length output_types' - 1]]+          ins = ["in" <> showText i | i <- [0 .. length input_types' - 1]]           onRes = either (Failure . pure) (const Success)       mapM (fmap onRes . runCompiledCase input_types' outs ins) run_cases   where@@ -398,7 +398,7 @@ compareResult _ _ _ (Succeeds _) (ErrorResult err) =   E.throwError $ "Function failed with error:\n" <> err compareResult _ _ _ (RunTimeFailure f) (SuccessResult _) =-  E.throwError $ "Program succeeded, but expected failure:\n  " <> T.pack (show f)+  E.throwError $ "Program succeeded, but expected failure:\n  " <> showText f  --- --- Test manager@@ -420,7 +420,7 @@ catching m = m `catch` save   where     save :: SomeException -> IO TestResult-    save e = pure $ Failure [T.pack $ show e]+    save e = pure $ Failure [showText e]  doTest :: TestCase -> IO TestResult doTest = catching . runTestM . runTestCase

@@ -200,14 +200,15 @@   GC.stm     [C.cstm|ctx->error =      CUDA_SUCCEED_NONFATAL(cuda_alloc(&ctx->cuda, ctx->log,-                                      (size_t)$exp:size, $exp:tag, &$exp:mem));|]+                                      (size_t)$exp:size, $exp:tag,+                                      &$exp:mem, (size_t*)&$exp:size));|] allocateCUDABuffer _ _ _ space =   error $ "Cannot allocate in '" ++ space ++ "' memory space."  deallocateCUDABuffer :: GC.Deallocate OpenCL ()-deallocateCUDABuffer mem tag "device" =-  GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(&ctx->cuda, $exp:mem, $exp:tag));|]-deallocateCUDABuffer _ _ space =+deallocateCUDABuffer mem size tag "device" =+  GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(&ctx->cuda, $exp:mem, $exp:size, $exp:tag));|]+deallocateCUDABuffer _ _ _ space =   error $ "Cannot deallocate in '" ++ space ++ "' memory space."  copyCUDAMemory :: GC.Copy OpenCL ()

@@ -25,8 +25,8 @@ import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.ImpCode.OpenCL-import Futhark.CodeGen.RTS.C (cudaH, freeListH)-import Futhark.Util (chunk, zEncodeString)+import Futhark.CodeGen.RTS.C (cudaH)+import Futhark.Util (chunk, zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C @@ -68,8 +68,6 @@     [C.cunit|       $esc:("#include <cuda.h>")       $esc:("#include <nvrtc.h>")-      $esc:("typedef CUdeviceptr fl_mem_t;")-      $esc:(T.unpack freeListH)       $esc:(T.unpack cudaH)       const char *cuda_program[] = {$inits:fragments, NULL};       |]@@ -88,15 +86,16 @@  generateSizeFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () () generateSizeFuns sizes = do-  let size_name_inits = map (\k -> [C.cinit|$string:(prettyString k)|]) $ M.keys sizes-      size_var_inits = map (\k -> [C.cinit|$string:(zEncodeString (prettyString k))|]) $ M.keys sizes-      size_class_inits = map (\c -> [C.cinit|$string:(prettyString c)|]) $ M.elems sizes+  let strinit s = [C.cinit|$string:(T.unpack s)|]+      size_name_inits = map (strinit . prettyText) $ M.keys sizes+      size_var_inits = map (strinit . zEncodeText . prettyText) $ M.keys sizes+      size_class_inits = map (strinit . prettyText) $ M.elems sizes    GC.earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits };|]   GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[] = { $inits:size_var_inits };|]   GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[] = { $inits:size_class_inits };|] -generateConfigFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () String+generateConfigFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () T.Text generateConfigFuns sizes = do   let size_decls = map (\k -> [C.csdecl|typename int64_t *$id:k;|]) $ M.keys sizes       num_sizes = M.size sizes@@ -294,7 +293,7 @@   pure cfg  generateContextFuns ::-  String ->+  T.Text ->   [Name] ->   M.Map KernelName KernelSafety ->   M.Map Name SizeClass ->@@ -335,6 +334,7 @@                          int profiling;                          int profiling_paused;                          int logging;+                         struct free_list free_list;                          typename lock_t lock;                          char *error;                          typename lock_t error_lock;@@ -376,7 +376,7 @@                  ctx->profiling_paused = 0;                  ctx->logging = cfg->cu_cfg.logging;                  ctx->error = NULL;-                 create_lock(&ctx->error_lock);+                 context_setup(ctx);                  ctx->log = stderr;                  ctx->cuda.profiling_records_capacity = 200;                  ctx->cuda.profiling_records_used = 0;@@ -385,7 +385,6 @@                           sizeof(struct profiling_record));                   ctx->cuda.cfg = cfg->cu_cfg;-                 create_lock(&ctx->lock);                   ctx->failure_is_an_option = 0;                  ctx->total_runs = 0;@@ -423,11 +422,10 @@     ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],       [C.cedecl|void $id:s(struct $id:ctx* ctx) {                                  $stms:free_fields-                                 free_constants(ctx);+                                 context_teardown(ctx);                                  cuMemFree(ctx->global_failure);                                  cuMemFree(ctx->global_failure_args);                                  cuda_cleanup(&ctx->cuda);-                                 free_lock(&ctx->lock);                                  ctx->cfg->in_use = 0;                                  free(ctx);                                }|]

@@ -213,14 +213,15 @@   GC.stm     [C.cstm|ctx->error =      OPENCL_SUCCEED_NONFATAL(opencl_alloc(&ctx->opencl, ctx->log,-                                          (size_t)$exp:size, $exp:tag, &$exp:mem));|]+                                          (size_t)$exp:size, $exp:tag,+                                          &$exp:mem, (size_t*)&$exp:size));|] allocateOpenCLBuffer _ _ _ space =   error $ "Cannot allocate in '" ++ space ++ "' memory space."  deallocateOpenCLBuffer :: GC.Deallocate OpenCL ()-deallocateOpenCLBuffer mem tag "device" =-  GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(&ctx->opencl, $exp:mem, $exp:tag));|]-deallocateOpenCLBuffer _ _ space =+deallocateOpenCLBuffer mem size tag "device" =+  GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(&ctx->opencl, $exp:mem, $exp:size, $exp:tag));|]+deallocateOpenCLBuffer _ _ _ space =   error $ "Cannot deallocate in '" ++ space ++ "' space"  syncArg :: GC.CopyBarrier -> C.Exp

@@ -26,8 +26,8 @@ import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.OpenCL.Heuristics-import Futhark.CodeGen.RTS.C (freeListH, openclH)-import Futhark.Util (chunk, zEncodeString)+import Futhark.CodeGen.RTS.C (openclH)+import Futhark.Util (chunk, zEncodeText) import Futhark.Util.Pretty (prettyTextOneLine) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C@@ -85,9 +85,10 @@    mapM_ GC.earlyDecl top_decls -  let size_name_inits = map (\k -> [C.cinit|$string:(prettyString k)|]) $ M.keys sizes-      size_var_inits = map (\k -> [C.cinit|$string:(zEncodeString (prettyString k))|]) $ M.keys sizes-      size_class_inits = map (\c -> [C.cinit|$string:(prettyString c)|]) $ M.elems sizes+  let strinit s = [C.cinit|$string:(T.unpack s)|]+      size_name_inits = map (strinit . prettyText) $ M.keys sizes+      size_var_inits = map (strinit . zEncodeText . prettyText) $ M.keys sizes+      size_class_inits = map (strinit . prettyText) $ M.elems sizes       num_sizes = M.size sizes    GC.earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits };|]@@ -320,6 +321,7 @@                          char *error;                          typename lock_t error_lock;                          typename FILE *log;+                         struct free_list free_list;                          $sdecls:fields                          $sdecls:ctx_opencl_fields                          typename cl_mem global_failure;@@ -342,14 +344,13 @@                      ctx->profiling_paused = 0;                      ctx->logging = cfg->opencl.logging;                      ctx->error = NULL;-                     create_lock(&ctx->error_lock);+                     context_setup(ctx);                      ctx->log = stderr;                      ctx->opencl.profiling_records_capacity = 200;                      ctx->opencl.profiling_records_used = 0;                      ctx->opencl.profiling_records =                        malloc(ctx->opencl.profiling_records_capacity *                               sizeof(struct profiling_record));-                     create_lock(&ctx->lock);                       ctx->failure_is_an_option = 0;                      $stms:init_fields@@ -453,8 +454,7 @@     ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],       [C.cedecl|void $id:s(struct $id:ctx* ctx) {                                  $stms:free_fields-                                 free_constants(ctx);-                                 free_lock(&ctx->lock);+                                 context_teardown(ctx);                                  $stms:(map releaseKernel (M.toList kernels))                                  OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure));                                  OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure_args));@@ -574,8 +574,6 @@     program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]]     openCL_boilerplate =       [C.cunit|-          $esc:("typedef cl_mem fl_mem_t;")-          $esc:(T.unpack freeListH)           $esc:(T.unpack openclH)           static const char *opencl_program[] = {$inits:program_fragments};|] 

@@ -33,7 +33,7 @@ import Futhark.CodeGen.Backends.GenericC.Server (serverDefs) import Futhark.CodeGen.Backends.GenericC.Types import Futhark.CodeGen.ImpCode-import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, errorsH, halfH, lockH, timingH, utilH)+import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, errorsH, freeListH, halfH, lockH, timingH, utilH) import Futhark.Manifest qualified as Manifest import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C@@ -134,7 +134,7 @@   -- Unreferencing a memory block consists of decreasing its reference   -- count and freeing the corresponding memory if the count reaches   -- zero.-  free <- collect $ freeRawMem [C.cexp|block->mem|] space [C.cexp|desc|]+  free <- collect $ freeRawMem [C.cexp|block->mem|] [C.cexp|block->size|] space [C.cexp|desc|]   ctx_ty <- contextType   let unrefdef =         [C.cedecl|int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) {@@ -403,6 +403,8 @@ $cacheH $halfH $timingH+$lockH+$freeListH |]    let early_decls = definitionsText $ DL.toList $ compEarlyDecls endstate@@ -421,8 +423,6 @@ #include <ctype.h>  $header_extra--$lockH  #define FUTHARK_F64_ENABLED 

@@ -7,14 +7,13 @@ where  import Control.Monad.Reader-import Data.Char (isAlpha, isAlphaNum) import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Monad import Futhark.CodeGen.Backends.GenericC.Types (opaqueToCType, valueTypeToCType) import Futhark.CodeGen.ImpCode import Futhark.Manifest qualified as Manifest-import Futhark.Util (zEncodeString)+import Futhark.Util (zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C @@ -132,17 +131,10 @@             [C.cstm|$exp:dest->shape[$int:i] = $id:d;|]       stms $ zipWith maybeCopyDim shape [0 .. rank - 1] -isValidCName :: Name -> Bool-isValidCName = check . nameToString-  where-    check [] = True -- academic-    check (c : cs) = isAlpha c && all constituent cs-    constituent c = isAlphaNum c || c == '_'--entryName :: Name -> String+entryName :: Name -> T.Text entryName v-  | isValidCName v = "entry_" <> nameToString v-  | otherwise = "entry_" <> zEncodeString (nameToString v)+  | isValidCName (nameToText v) = "entry_" <> nameToText v+  | otherwise = "entry_" <> zEncodeText (nameToText v)  onEntryPoint ::   [C.BlockItem] ->@@ -221,7 +213,7 @@        manifest =         Manifest.EntryPoint-          { Manifest.entryPointCFun = T.pack entry_point_function_name,+          { Manifest.entryPointCFun = entry_point_function_name,             -- Note that our convention about what is "input/output"             -- and what is "results/args" is different between the             -- manifest and ImpCode.@@ -238,13 +230,12 @@       decl [C.cdecl|$ty:ty' $id:name;|]      vdType (TransparentValue (ScalarValue pt signed _)) =-      T.pack $ prettySigned (signed == Unsigned) pt+      prettySigned (signed == Unsigned) pt     vdType (TransparentValue (ArrayValue _ _ pt signed shape)) =-      T.pack $-        mconcat (replicate (length shape) "[]")-          <> prettySigned (signed == Unsigned) pt+      mconcat (replicate (length shape) "[]")+        <> prettySigned (signed == Unsigned) pt     vdType (OpaqueValue name _) =-      T.pack name+      nameToText name      outputManifest (u, vd) =       Manifest.Output

@@ -77,6 +77,7 @@     fatMemUnRef,     criticalSection,     module Futhark.CodeGen.Backends.SimpleRep,+    isValidCName,   ) where @@ -84,6 +85,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (first)+import Data.Char (isAlpha, isAlphaNum) import Data.DList qualified as DL import Data.List (unzip4) import Data.Loc@@ -140,9 +142,9 @@ -- | In which part of the header file we put the declaration.  This is -- to ensure that the header file remains structured and readable. data HeaderSection-  = ArrayDecl String-  | OpaqueTypeDecl String-  | OpaqueDecl String+  = ArrayDecl Name+  | OpaqueTypeDecl Name+  | OpaqueDecl Name   | EntryDecl   | MiscDecl   | InitDecl@@ -181,9 +183,9 @@   SpaceId ->   CompilerM op s () --- | De-allocate the given memory block with the given tag, which is--- in the given memory space.-type Deallocate op s = C.Exp -> C.Exp -> SpaceId -> CompilerM op s ()+-- | De-allocate the given memory block, with the given tag, with the+-- given size,, which is in the given memory space.+type Deallocate op s = C.Exp -> C.Exp -> C.Exp -> SpaceId -> CompilerM op s ()  -- | Create a static array of values - initialised at load time. type StaticArray op s = VName -> SpaceId -> PrimType -> ArrayContents -> CompilerM op s ()@@ -351,10 +353,10 @@ -- header file, and the second is the implementation.  Returns the public -- name. publicDef ::-  String ->+  T.Text ->   HeaderSection ->-  (String -> (C.Definition, C.Definition)) ->-  CompilerM op s String+  (T.Text -> (C.Definition, C.Definition)) ->+  CompilerM op s T.Text publicDef s h f = do   s' <- publicName s   let (pub, priv) = f s'@@ -364,9 +366,9 @@  -- | As 'publicDef', but ignores the public name. publicDef_ ::-  String ->+  T.Text ->   HeaderSection ->-  (String -> (C.Definition, C.Definition)) ->+  (T.Text -> (C.Definition, C.Definition)) ->   CompilerM op s () publicDef_ s h f = void $ publicDef s h f @@ -414,8 +416,8 @@ decl x = item [C.citem|$decl:x;|]  -- | Public names must have a consitent prefix.-publicName :: String -> CompilerM op s String-publicName s = pure $ "futhark_" ++ s+publicName :: T.Text -> CompilerM op s T.Text+publicName s = pure $ "futhark_" <> s  memToCType :: VName -> Space -> CompilerM op s C.Type memToCType v space = do@@ -480,20 +482,24 @@         <*> pure [C.cexp|$exp:desc|]         <*> pure sid   _ ->-    stm [C.cstm|$exp:dest = (unsigned char*) malloc((size_t)$exp:size);|]+    stm+      [C.cstm|host_alloc(ctx, (size_t)$exp:size, $exp:desc, (size_t*)&$exp:size, (void*)&$exp:dest);|]  freeRawMem ::-  (C.ToExp a, C.ToExp b) =>+  (C.ToExp a, C.ToExp b, C.ToExp c) =>   a ->-  Space ->   b ->+  Space ->+  c ->   CompilerM op s ()-freeRawMem mem space desc =+freeRawMem mem size space desc =   case space of     Space sid -> do       free_mem <- asks (opsDeallocate . envOperations)-      free_mem [C.cexp|$exp:mem|] [C.cexp|$exp:desc|] sid-    _ -> item [C.citem|free($exp:mem);|]+      free_mem [C.cexp|$exp:mem|] [C.cexp|$exp:size|] [C.cexp|$exp:desc|] sid+    _ ->+      item+        [C.citem|host_free(ctx, (size_t)$exp:size, $exp:desc, (void*)$exp:mem);|]  declMem :: VName -> Space -> CompilerM op s () declMem name space = do@@ -569,7 +575,7 @@                        $stm:on_failure                      }|]     else do-      freeRawMem mem space mem_s+      freeRawMem mem size space mem_s       allocRawMem mem size space [C.cexp|desc|]  copyMemoryDefaultSpace ::@@ -666,3 +672,11 @@ configType = do   name <- publicName "context_config"   pure [C.cty|struct $id:name|]++-- | Is this name a valid C identifier?  If not, it should be escaped+-- before being emitted into C.+isValidCName :: T.Text -> Bool+isValidCName = maybe True check . T.uncons+  where+    check (c, cs) = isAlpha c && T.all constituent cs+    constituent c = isAlphaNum c || c == '_'

@@ -14,7 +14,7 @@ import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH) import Futhark.Manifest-import Futhark.Util (zEncodeString)+import Futhark.Util (zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C import Language.Futhark.Core (nameFromText)@@ -105,8 +105,8 @@       }   ] -typeStructName :: T.Text -> String-typeStructName tname = "type_" <> zEncodeString (T.unpack tname)+typeStructName :: T.Text -> T.Text+typeStructName tname = "type_" <> zEncodeText tname  cType :: Manifest -> TypeName -> C.Type cType manifest tname =@@ -120,8 +120,8 @@ typeBoilerplate :: Manifest -> (T.Text, Type) -> (C.Definition, C.Initializer, [C.Definition]) typeBoilerplate _ (tname, TypeArray _ et rank ops) =   let type_name = typeStructName tname-      aux_name = type_name ++ "_aux"-      info_name = T.unpack et ++ "_info"+      aux_name = type_name <> "_aux"+      info_name = et <> "_info"       shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]]       array_new_wrap = arrayNew ops <> "_wrap"    in ( [C.cedecl|const struct type $id:type_name;|],

@@ -18,11 +18,11 @@ import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.ImpCode import Futhark.Manifest qualified as Manifest-import Futhark.Util (chunks, mapAccumLM)+import Futhark.Util (chunks, mapAccumLM, zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C -opaqueToCType :: String -> CompilerM op s C.Type+opaqueToCType :: Name -> CompilerM op s C.Type opaqueToCType desc = do   name <- publicName $ opaqueName desc   pure [C.cty|struct $id:name|]@@ -46,17 +46,17 @@ arrayLibraryFunctions pub space pt signed rank = do   let pt' = primAPIType signed pt       name = arrayName pt signed rank-      arr_name = "futhark_" ++ name+      arr_name = "futhark_" <> name       array_type = [C.cty|struct $id:arr_name|] -  new_array <- publicName $ "new_" ++ name-  new_raw_array <- publicName $ "new_raw_" ++ name-  free_array <- publicName $ "free_" ++ name-  values_array <- publicName $ "values_" ++ name-  values_raw_array <- publicName $ "values_raw_" ++ name-  shape_array <- publicName $ "shape_" ++ name+  new_array <- publicName $ "new_" <> name+  new_raw_array <- publicName $ "new_raw_" <> name+  free_array <- publicName $ "free_" <> name+  values_array <- publicName $ "values_" <> name+  values_raw_array <- publicName $ "values_raw_" <> name+  shape_array <- publicName $ "shape_" <> name -  let shape_names = ["dim" ++ show i | i <- [0 .. rank - 1]]+  let shape_names = ["dim" <> prettyText i | i <- [0 .. rank - 1]]       shape_params = [[C.cparam|typename int64_t $id:k|] | k <- shape_names]       arr_size = cproduct [[C.cexp|$id:k|] | k <- shape_names]       arr_size_array = cproduct [[C.cexp|arr->shape[$int:i]|] | i <- [0 .. rank - 1]]@@ -117,7 +117,7 @@   ops <- asks envOperations    let proto = case pub of-        Public -> headerDecl (ArrayDecl name)+        Public -> headerDecl (ArrayDecl (nameFromText name))         Private -> libDecl    proto@@ -183,13 +183,13 @@    pure $     Manifest.ArrayOps-      { Manifest.arrayFree = T.pack free_array,-        Manifest.arrayShape = T.pack shape_array,-        Manifest.arrayValues = T.pack values_array,-        Manifest.arrayNew = T.pack new_array+      { Manifest.arrayFree = free_array,+        Manifest.arrayShape = shape_array,+        Manifest.arrayValues = values_array,+        Manifest.arrayNew = new_array       } -lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType+lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType lookupOpaqueType v (OpaqueTypes types) =   case lookup v types of     Just t -> t@@ -207,7 +207,7 @@ entryPointTypeToCType pub (TypeTransparent vt) = valueTypeToCType pub vt  entryTypeName :: EntryPointType -> Manifest.TypeName-entryTypeName (TypeOpaque desc) = T.pack desc+entryTypeName (TypeOpaque desc) = nameToText desc entryTypeName (TypeTransparent vt) = prettyText vt  -- | Figure out which of the members of an opaque type corresponds to@@ -221,7 +221,7 @@  opaqueProjectFunctions ::   OpaqueTypes ->-  String ->+  Name ->   [(Name, EntryPointType)] ->   [ValueType] ->   CompilerM op s [Manifest.RecordField]@@ -263,7 +263,11 @@                         $items:(concat (zipWith setField [0..] components))|]           )   let onField ((f, et), elems) = do-        project <- publicName $ "project_" ++ opaqueName desc ++ "_" ++ nameToString f+        let f' =+              if isValidCName $ opaqueName desc <> "_" <> nameToText f+                then nameToText f+                else zEncodeText (nameToText f)+        project <- publicName $ "project_" <> opaqueName desc <> "_" <> f'         (et_ty, project_items) <- mkProject et elems         headerDecl           (OpaqueDecl desc)@@ -276,14 +280,14 @@                       *out = v;                       return 0;                     }|]-        pure $ Manifest.RecordField (nameToText f) (entryTypeName et) (T.pack project)+        pure $ Manifest.RecordField (nameToText f) (entryTypeName et) project    mapM onField . zip fs . recordFieldPayloads types (map snd fs) $     zip [0 ..] vds  opaqueNewFunctions ::   OpaqueTypes ->-  String ->+  Name ->   [(Name, EntryPointType)] ->   [ValueType] ->   CompilerM op s Manifest.CFuncName@@ -291,7 +295,7 @@   opaque_type <- opaqueToCType desc   ctx_ty <- contextType   ops <- asks envOperations-  new <- publicName $ "new_" ++ opaqueName desc+  new <- publicName $ "new_" <> opaqueName desc    (params, new_stms) <-     fmap (unzip . snd)@@ -310,13 +314,13 @@                 *out = v;                 return 0;               }|]-  pure $ T.pack new+  pure new   where     onField offset ((f, et), f_vts) = do       let param_name =-            if all isDigit (nameToString f)+            if T.all isDigit (nameToText f)               then C.toIdent ("v" <> f) mempty-              else C.toIdent f mempty+              else C.toIdent ("f_" <> f) mempty       case et of         TypeTransparent (ValueType sign (Rank 0) pt) -> do           let ct = primAPIType sign pt@@ -358,7 +362,7 @@  processOpaqueRecord ::   OpaqueTypes ->-  String ->+  Name ->   OpaqueType ->   [ValueType] ->   CompilerM op s (Maybe Manifest.RecordOps)@@ -372,20 +376,20 @@  opaqueLibraryFunctions ::   OpaqueTypes ->-  String ->+  Name ->   OpaqueType ->   CompilerM op s (Manifest.OpaqueOps, Maybe Manifest.RecordOps) opaqueLibraryFunctions types desc ot = do   name <- publicName $ opaqueName desc-  free_opaque <- publicName $ "free_" ++ opaqueName desc-  store_opaque <- publicName $ "store_" ++ opaqueName desc-  restore_opaque <- publicName $ "restore_" ++ opaqueName desc+  free_opaque <- publicName $ "free_" <> opaqueName desc+  store_opaque <- publicName $ "store_" <> opaqueName desc+  restore_opaque <- publicName $ "restore_" <> opaqueName desc    let opaque_type = [C.cty|struct $id:name|]        freeComponent i (ValueType signed (Rank rank) pt) = unless (rank == 0) $ do         let field = tupleField i-        free_array <- publicName $ "free_" ++ arrayName pt signed rank+        free_array <- publicName $ "free_" <> arrayName pt signed rank         -- Protect against NULL here, because we also want to use this         -- to free partially loaded opaques.         stm@@ -403,8 +407,8 @@       storeComponent i (ValueType sign (Rank rank) pt) =         let arr_name = arrayName pt sign rank             field = tupleField i-            shape_array = "futhark_shape_" ++ arr_name-            values_array = "futhark_values_" ++ arr_name+            shape_array = "futhark_shape_" <> arr_name+            values_array = "futhark_values_" <> arr_name             shape' = [C.cexp|$id:shape_array(ctx, obj->$id:field)|]             num_elems = cproduct [[C.cexp|$exp:shape'[$int:j]|] | j <- [0 .. rank - 1]]          in ( storageSize pt rank shape',@@ -438,9 +442,9 @@       restoreComponent i (ValueType sign (Rank rank) pt) = do         let field = tupleField i             arr_name = arrayName pt sign rank-            new_array = "futhark_new_" ++ arr_name-            dataptr = "data_" ++ show i-            shapearr = "shape_" ++ show i+            new_array = "futhark_new_" <> arr_name+            dataptr = "data_" <> prettyText i+            shapearr = "shape_" <> prettyText i             dims = [[C.cexp|$id:shapearr[$int:j]|] | j <- [0 .. rank - 1]]             num_elems = cproduct dims         item [C.citem|typename int64_t $id:shapearr[$int:rank] = {0};|]@@ -516,9 +520,9 @@    pure     ( Manifest.OpaqueOps-        { Manifest.opaqueFree = T.pack free_opaque,-          Manifest.opaqueStore = T.pack store_opaque,-          Manifest.opaqueRestore = T.pack restore_opaque+        { Manifest.opaqueFree = free_opaque,+          Manifest.opaqueStore = store_opaque,+          Manifest.opaqueRestore = restore_opaque         },       record     )@@ -532,7 +536,7 @@   let memty = fatMemType space   libDecl [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|]   ops <- arrayLibraryFunctions pub space pt signed rank-  let pt_name = T.pack $ prettySigned (signed == Unsigned) pt+  let pt_name = prettySigned (signed == Unsigned) pt       pretty_name = mconcat (replicate rank "[]") <> pt_name       arr_type = [C.cty|struct $id:name*|]   case pub of@@ -547,7 +551,7 @@  generateOpaque ::   OpaqueTypes ->-  (String, OpaqueType) ->+  (Name, OpaqueType) ->   CompilerM op s (T.Text, Manifest.Type) generateOpaque types (desc, ot) = do   name <- publicName $ opaqueName desc@@ -555,7 +559,7 @@   libDecl [C.cedecl|struct $id:name { $sdecls:members };|]   (ops, record) <- opaqueLibraryFunctions types desc ot   let opaque_type = [C.cty|struct $id:name*|]-  pure (T.pack desc, Manifest.TypeOpaque (typeText opaque_type) ops record)+  pure (nameToText desc, Manifest.TypeOpaque (typeText opaque_type) ops record)   where     field vt@(ValueType _ (Rank r) _) i = do       ct <- valueTypeToCType Private vt

@@ -55,7 +55,7 @@ import Futhark.IR.Prop (isBuiltInFunction, subExpVars) import Futhark.IR.Syntax.Core (Space (..)) import Futhark.MonadFreshNames-import Futhark.Util (zEncodeString)+import Futhark.Util (zEncodeText) import Futhark.Util.Pretty (prettyString, prettyText) import Language.Futhark.Primitive hiding (Bool) @@ -249,8 +249,8 @@ stm :: PyStmt -> CompilerM op s () stm x = tell [x] -futharkFun :: String -> String-futharkFun s = "futhark_" ++ zEncodeString s+futharkFun :: T.Text -> T.Text+futharkFun s = "futhark_" <> zEncodeText s  compileOutput :: [Imp.Param] -> [PyExp] compileOutput = map (Var . compileName . Imp.paramName)@@ -331,7 +331,7 @@ functionExternalValues entry =   map snd (Imp.entryPointResults entry) ++ map snd (Imp.entryPointArgs entry) -opaqueDefs :: Imp.Functions a -> M.Map String [PyExp]+opaqueDefs :: Imp.Functions a -> M.Map T.Text [PyExp] opaqueDefs (Imp.Functions funs) =   mconcat     . map evd@@ -340,11 +340,11 @@     $ funs   where     evd Imp.TransparentValue {} = mempty-    evd (Imp.OpaqueValue name vds) = M.singleton name $ map (String . vd) vds+    evd (Imp.OpaqueValue name vds) = M.singleton (nameToText name) $ map (String . vd) vds     vd (Imp.ScalarValue pt s _) =       readTypeEnum pt s     vd (Imp.ArrayValue _ _ pt s dims) =-      concat (replicate (length dims) "[]") ++ readTypeEnum pt s+      mconcat (replicate (length dims) "[]") <> readTypeEnum pt s  -- | The class generated by the code generator must have a -- constructor, although it can be vacuous.@@ -490,12 +490,9 @@   local $ \env -> env {envVarExp = foldMap constExp ps}   where     constExp p =-      M.singleton (Imp.paramName p) $-        Index (Var "self.constants") $-          IdxExp $-            String $-              prettyString $-                Imp.paramName p+      M.singleton+        (Imp.paramName p)+        (Index (Var "self.constants") $ IdxExp $ String $ prettyText $ Imp.paramName p)  compileConstants :: Imp.Constants op -> CompilerM op s () compileConstants (Imp.Constants _ init_consts) = do@@ -508,7 +505,7 @@   let inputs' = map (compileName . Imp.paramName) inputs   let ret = Return $ tupleOrSingle $ compileOutput outputs   pure $-    Def (futharkFun . nameToString $ fname) ("self" : inputs') $+    Def (T.unpack $ futharkFun $ nameToText fname) ("self" : inputs') $       body' ++ [ret]  tupleOrSingle :: [PyExp] -> PyExp@@ -521,7 +518,7 @@ simpleCall fname = Call (Var fname) . map Arg  compileName :: VName -> String-compileName = zEncodeString . prettyString+compileName = T.unpack . zEncodeText . prettyText  compileDim :: Imp.DimSize -> CompilerM op s PyExp compileDim (Imp.Constant v) = pure $ compilePrimValue v@@ -549,7 +546,7 @@  entryPointOutput :: Imp.ExternalValue -> CompilerM op s PyExp entryPointOutput (Imp.OpaqueValue desc vs) =-  simpleCall "opaque" . (String (prettyString desc) :)+  simpleCall "opaque" . (String (prettyText desc) :)     <$> mapM (entryPointOutput . Imp.TransparentValue) vs entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = do   name' <- compileVar name@@ -564,7 +561,7 @@   dims' <- mapM compileDim dims   pure $ simpleCall "createArray" [mem', Tuple dims', Var $ compilePrimToExtNp bt ept] -badInput :: Int -> PyExp -> String -> PyStmt+badInput :: Int -> PyExp -> T.Text -> PyStmt badInput i e t =   Raise $     simpleCall@@ -575,13 +572,13 @@       ]   where     err_msg =-      unlines-        [ "Argument #" ++ show i ++ " has invalid value",+      T.unlines+        [ "Argument #" <> prettyText i <> " has invalid value",           "Futhark type: {}",           "Argument has Python type {} and value: {}"         ] -badInputType :: Int -> PyExp -> String -> PyExp -> PyExp -> PyStmt+badInputType :: Int -> PyExp -> T.Text -> PyExp -> PyExp -> PyStmt badInputType i e t de dg =   Raise $     simpleCall@@ -592,15 +589,15 @@       ]   where     err_msg =-      unlines-        [ "Argument #" ++ show i ++ " has invalid value",+      T.unlines+        [ "Argument #" <> prettyText i <> " has invalid value",           "Futhark type: {}",           "Argument has Python type {} and value: {}",           "Expected array with elements of dtype: {}",           "The array given has elements of dtype: {}"         ] -badInputDim :: Int -> PyExp -> String -> Int -> PyStmt+badInputDim :: Int -> PyExp -> T.Text -> Int -> PyStmt badInputDim i e typ dimf =   Raise $     simpleCall@@ -610,11 +607,11 @@           [Arg eft, Arg aft]       ]   where-    eft = String (concat (replicate dimf "[]") ++ typ)+    eft = String (mconcat (replicate dimf "[]") <> typ)     aft = BinOp "+" (BinOp "*" (String "[]") (Field e "ndim")) (String typ)     err_msg =-      unlines-        [ "Argument #" ++ show i ++ " has invalid value",+      T.unlines+        [ "Argument #" <> prettyText i <> " has invalid value",           "Dimensionality mismatch",           "Expected Futhark type: {}",           "Bad Python value passed",@@ -636,8 +633,8 @@         BinOp           "and"           (simpleCall "isinstance" [e, Var "opaque"])-          (BinOp "==" (Field e "desc") (String desc))-  stm $ If (UnOp "not" type_is_ok) [badInput i e desc] []+          (BinOp "==" (Field e "desc") (String (nameToText desc)))+  stm $ If (UnOp "not" type_is_ok) [badInput i e (nameToText desc)] []   mapM_ entryPointInput $     zip3 (repeat i) (map Imp.TransparentValue vs) $       map (Index (Field e "data") . IdxExp . Integer) [0 ..]@@ -674,8 +671,8 @@       [ Catch           (Tuple [Var "TypeError", Var "AssertionError"])           [ badInput i e $-              concat (replicate (length dims) "[]")-                ++ prettySigned (ept == Imp.Unsigned) bt+              mconcat (replicate (length dims) "[]")+                <> prettySigned (ept == Imp.Unsigned) bt           ]       ] entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem _ t s dims), e) = do@@ -686,8 +683,8 @@     If       type_is_wrong       [ badInput i e $-          concat (replicate (length dims) "[]")-            ++ prettySigned (s == Imp.Unsigned) t+          mconcat (replicate (length dims) "[]")+            <> prettySigned (s == Imp.Unsigned) t       ]       []   stm $@@ -696,7 +693,7 @@       [ badInputType           i           e-          (concat (replicate (length dims) "[]") ++ prettySigned (s == Imp.Unsigned) t)+          (mconcat (replicate (length dims) "[]") <> prettySigned (s == Imp.Unsigned) t)           (simpleCall "np.dtype" [Var (compilePrimToExtNp t s)])           (Field e "dtype")       ]@@ -713,24 +710,21 @@    stm $ Assign dest unwrap_call -extValueDescName :: Imp.ExternalValue -> String-extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v-extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc+extValueDescName :: Imp.ExternalValue -> T.Text+extValueDescName (Imp.TransparentValue v) = extName $ T.pack $ compileName $ valueDescVName v+extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeText $ nameToText desc extValueDescName (Imp.OpaqueValue desc (v : _)) =-  extName $ zEncodeString desc ++ "_" ++ prettyString (baseTag (valueDescVName v))--extName :: String -> String-extName = (++ "_ext")+  extName $ zEncodeText (nameToText desc) <> "_" <> prettyText (baseTag (valueDescVName v)) -valueDescName :: Imp.ValueDesc -> String-valueDescName = compileName . valueDescVName+extName :: T.Text -> T.Text+extName = (<> "_ext")  valueDescVName :: Imp.ValueDesc -> VName valueDescVName (Imp.ScalarValue _ _ vname) = vname valueDescVName (Imp.ArrayValue vname _ _ _ _) = vname  -- Key into the FUTHARK_PRIMTYPES dict.-readTypeEnum :: PrimType -> Imp.Signedness -> String+readTypeEnum :: PrimType -> Imp.Signedness -> T.Text readTypeEnum (IntType Int8) Imp.Unsigned = "u8" readTypeEnum (IntType Int16) Imp.Unsigned = "u16" readTypeEnum (IntType Int32) Imp.Unsigned = "u32"@@ -750,16 +744,16 @@   Raise $     simpleCall       "Exception"-      [String $ "Cannot read argument of type " ++ desc ++ "."]+      [String $ "Cannot read argument of type " <> nameToText desc <> "."] readInput decl@(Imp.TransparentValue (Imp.ScalarValue bt ept _)) =   let type_name = readTypeEnum bt ept-   in Assign (Var $ extValueDescName decl) $ simpleCall "read_value" [String type_name]+   in Assign (Var $ T.unpack $ extValueDescName decl) $ simpleCall "read_value" [String type_name] readInput decl@(Imp.TransparentValue (Imp.ArrayValue _ _ bt ept dims)) =   let type_name = readTypeEnum bt ept-   in Assign (Var $ extValueDescName decl) $+   in Assign (Var $ T.unpack $ extValueDescName decl) $         simpleCall           "read_value"-          [String $ concat (replicate (length dims) "[]") ++ type_name]+          [String $ mconcat (replicate (length dims) "[]") <> type_name]  printValue :: [(Imp.ExternalValue, PyExp)] -> CompilerM op s [PyStmt] printValue = fmap concat . mapM (uncurry printValue')@@ -774,7 +768,7 @@         [ Exp $             simpleCall               "sys.stdout.write"-              [String $ "#<opaque " ++ desc ++ ">"]+              [String $ "#<opaque " <> nameToText desc <> ">"]         ]     printValue' (Imp.TransparentValue (Imp.ArrayValue mem (Space _) bt ept shape)) e =       printValue' (Imp.TransparentValue (Imp.ArrayValue mem DefaultSpace bt ept shape)) $@@ -809,11 +803,11 @@   prepareIn <- collect $ do     declEntryPointInputSizes $ map snd args     mapM_ entryPointInput . zip3 [0 ..] (map snd args) $-      map (Var . extValueDescName . snd) args+      map (Var . T.unpack . extValueDescName . snd) args   (res, prepareOut) <- collect' $ mapM (entryPointOutput . snd) results    let argexps_lib = map (compileName . Imp.paramName) inputs-      fname' = "self." ++ futharkFun (nameToString fname)+      fname' = "self." <> futharkFun (nameToText fname)        -- We ignore overflow errors and the like for executable entry       -- points.  These are (somewhat) well-defined in Futhark.@@ -823,11 +817,11 @@       call argexps =         [ With             errstate-            [Assign funTuple $ simpleCall fname' (fmap Var argexps)]+            [Assign funTuple $ simpleCall (T.unpack fname') (fmap Var argexps)]         ]    pure-    ( map (extValueDescName . snd) args,+    ( map (T.unpack . extValueDescName . snd) args,       prepareIn,       call argexps_lib,       prepareOut,@@ -894,31 +888,31 @@         Just           ( Def (nameToString ename) ("self" : params) $               prepareIn ++ do_run ++ prepareOut ++ sync ++ [ret],-            (String (nameToString ename), Tuple [List (map String pts), List (map String rts)])+            (String (nameToText ename), Tuple [List (map String pts), List (map String rts)])           )   | otherwise = pure Nothing -entryTypes :: Imp.EntryPoint -> ([String], [String])+entryTypes :: Imp.EntryPoint -> ([T.Text], [T.Text]) entryTypes (Imp.EntryPoint _ res args) =   (map descArg args, map desc res)   where     descArg ((_, u), d) = desc (u, d)-    desc (u, Imp.OpaqueValue d _) = prettyString u <> d-    desc (u, Imp.TransparentValue (Imp.ScalarValue pt s _)) = prettyString u <> readTypeEnum pt s+    desc (u, Imp.OpaqueValue d _) = prettyText u <> nameToText d+    desc (u, Imp.TransparentValue (Imp.ScalarValue pt s _)) = prettyText u <> readTypeEnum pt s     desc (u, Imp.TransparentValue (Imp.ArrayValue _ _ pt s dims)) =-      prettyString u <> concat (replicate (length dims) "[]") <> readTypeEnum pt s+      prettyText u <> mconcat (replicate (length dims) "[]") <> readTypeEnum pt s  callEntryFun ::   [PyStmt] ->   (Name, Imp.Function op) ->-  CompilerM op s (Maybe (PyFunDef, String, PyExp))+  CompilerM op s (Maybe (PyFunDef, T.Text, PyExp)) callEntryFun _ (_, Imp.Function Nothing _ _ _) = pure Nothing callEntryFun pre_timing fun@(fname, Imp.Function (Just entry) _ _ _) = do   let Imp.EntryPoint ename _ decl_args = entry   (_, prepare_in, body_bin, _, res) <- prepareEntry entry fun    let str_input = map (readInput . snd) decl_args-      end_of_input = [Exp $ simpleCall "end_of_input" [String $ prettyString fname]]+      end_of_input = [Exp $ simpleCall "end_of_input" [String $ prettyText fname]]        exitcall = [Exp $ simpleCall "sys.exit" [Field (String "Assertion.{} failed") "format(e)"]]       except' = Catch (Var "AssertionError") exitcall@@ -947,7 +941,7 @@             ++ [Try [do_warmup_run, do_num_runs] [except']]             ++ [close_runtime_file]             ++ str_output,-        nameToString ename,+        nameToText ename,         Var fname'       ) @@ -1151,14 +1145,14 @@ compilePrimExp f (Imp.UnOpExp op exp1) =   UnOp (compileUnOp op) <$> compilePrimExp f exp1 compilePrimExp f (Imp.FunExp h args _) =-  simpleCall (futharkFun (prettyString h)) <$> mapM (compilePrimExp f) args+  simpleCall (T.unpack (futharkFun (prettyText h))) <$> mapM (compilePrimExp f) args  compileExp :: Imp.Exp -> CompilerM op s PyExp compileExp = compilePrimExp compileVar -errorMsgString :: Imp.ErrorMsg Imp.Exp -> CompilerM op s (String, [PyExp])+errorMsgString :: Imp.ErrorMsg Imp.Exp -> CompilerM op s (T.Text, [PyExp]) errorMsgString (Imp.ErrorMsg parts) = do-  let onPart (Imp.ErrorString s) = pure ("%s", String $ T.unpack s)+  let onPart (Imp.ErrorString s) = pure ("%s", String s)       onPart (Imp.ErrorVal IntType {} x) = ("%d",) <$> compileExp x       onPart (Imp.ErrorVal FloatType {} x) = ("%f",) <$> compileExp x       onPart (Imp.ErrorVal Imp.Bool x) = ("%r",) <$> compileExp x@@ -1246,18 +1240,18 @@       e'       ( BinOp           "%"-          (String $ "Error: " ++ formatstr ++ "\n\nBacktrace:\n" ++ stacktrace)+          (String $ "Error: " <> formatstr <> "\n\nBacktrace:\n" <> stacktrace)           (Tuple formatargs)       )   where-    stacktrace = T.unpack $ prettyStacktrace 0 $ map locText $ loc : locs+    stacktrace = prettyStacktrace 0 $ map locText $ loc : locs compileCode (Imp.Call dests fname args) = do   args' <- mapM compileArg args   dests' <- tupleOrSingle <$> mapM compileVar dests   let fname'-        | isBuiltInFunction fname = futharkFun (prettyString fname)-        | otherwise = "self." ++ futharkFun (prettyString fname)-      call' = simpleCall fname' args'+        | isBuiltInFunction fname = futharkFun (prettyText fname)+        | otherwise = "self." <> futharkFun (prettyText fname)+      call' = simpleCall (T.unpack fname') args'   -- If the function returns nothing (is called only for side   -- effects), take care not to assign to an empty tuple.   stm $

@@ -30,7 +30,7 @@   = Integer Integer   | Bool Bool   | Float Double-  | String String+  | String T.Text   | RawStringLiteral T.Text   | Var String   | BinOp String PyExp PyExp

@@ -9,6 +9,7 @@   ) where +import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericPython.AST  -- | Specification if a single command line option.  The option must@@ -17,7 +18,7 @@ -- When the statement is being executed, the argument (if any) will be -- stored in the variable @optarg@. data Option = Option-  { optionLongName :: String,+  { optionLongName :: T.Text,     optionShortName :: Maybe Char,     optionArgument :: OptionArgument,     optionAction :: [PyStmt]@@ -53,15 +54,14 @@     parseOption option =       Exp $         Call (Var "parser.add_argument") $-          map (Arg . String) name_args-            ++ argument_args+          map (Arg . String) name_args ++ argument_args       where         name_args =           maybe             id-            ((:) . ('-' :) . (: []))+            (\x l -> ("-" <> T.singleton x) : l)             (optionShortName option)-            ["--" ++ optionLongName option]+            ["--" <> optionLongName option]         argument_args = case optionArgument option of           RequiredArgument t ->             [ ArgKeyword "action" (String "append"),@@ -82,14 +82,11 @@     executeOption option =       For         "optarg"-        ( Index (Var "parser_result") $-            IdxExp $-              String $-                fieldName option+        ( Index (Var "parser_result") $ IdxExp $ String $ fieldName option         )         $ optionAction option -    fieldName = map escape . optionLongName+    fieldName = T.map escape . optionLongName       where         escape '-' = '_'         escape c = c

@@ -21,6 +21,7 @@ import Futhark.CodeGen.Backends.SimpleRep (opaqueName) import Futhark.CodeGen.ImpCode.Sequential qualified as Imp import Futhark.CodeGen.RTS.JavaScript+import Futhark.Util (showText) import Language.Futhark.Primitive import NeatInterpolation (text) @@ -40,7 +41,7 @@ extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int64) Imp.Unsigned _)) = "u64" extToString (Imp.TransparentValue (Imp.ScalarValue Bool _ _)) = "bool" extToString (Imp.TransparentValue (Imp.ScalarValue Unit _ _)) = error "extToString: Unit"-extToString (Imp.OpaqueValue oname _) = opaqueName oname+extToString (Imp.OpaqueValue oname _) = T.unpack $ opaqueName oname  type EntryPointType = String @@ -154,8 +155,8 @@   |]   where     ename = T.pack $ name jse-    params = T.pack $ show $ parameters jse-    rets = T.pack $ show $ ret jse+    params = showText $ parameters jse+    rets = showText $ ret jse  jsWrapEntryPoint :: JSEntryPoint -> T.Text jsWrapEntryPoint jse =@@ -315,7 +316,7 @@     fvalues = "this.wasm._futhark_values_raw_" ++ signature     ffree = "this.wasm._futhark_free_" ++ signature     arraynd = "array" ++ show d ++ "d"-    shift = T.pack $ show (typeShift ftype)+    shift = showText (typeShift ftype)     heapType = T.pack heap     arraynd_flat = if d > 1 then arraynd ++ ".flat()" else arraynd     arraynd_dims = intercalate ", " [arraynd ++ mult i "[0]" ++ ".length" | i <- [0 .. d - 1]]

@@ -147,6 +147,7 @@                       typename FILE *log;                       int total_runs;                       long int total_runtime;+                      struct free_list free_list;                       $sdecls:fields                        // Tuning parameters@@ -174,10 +175,10 @@              ctx->profiling_paused = 0;              ctx->logging = 0;              ctx->error = NULL;-             create_lock(&ctx->error_lock);              ctx->log = stderr;-             create_lock(&ctx->lock); +             context_setup(ctx);+              int tune_kappa = 0;              double kappa = 5.1f * 1000; @@ -206,9 +207,8 @@     ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],       [C.cedecl|void $id:s(struct $id:ctx* ctx) {              $stms:free_fields-             free_constants(ctx);+             context_teardown(ctx);              (void)scheduler_destroy(&ctx->scheduler);-             free_lock(&ctx->lock);              ctx->cfg->in_use = 0;              free(ctx);            }|]

@@ -243,18 +243,18 @@        GC.libDecl         =<< pure-          [C.cedecl|int $id:((funName fname) ++ "_extern")($params:extra_c, $params:outparams_c, $params:inparams_c) {+          [C.cedecl|int $id:(funName fname <> "_extern")($params:extra_c, $params:outparams_c, $params:inparams_c) {                   return $id:(funName fname)($args:extra_exp, $args:out_args_c, $args:in_args_c);                 }|]        let ispc_extern =-            [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:((funName fname) ++ "_extern")+            [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:((funName fname) <> "_extern")                       ($params:extra, $params:outparams_extern, $params:inparams_extern);|]            ispc_uniform =             [C.cedecl|$tyqual:uniform int $id:(funName fname)                     ($params:extra, $params:outparams_uni, $params:inparams_uni) {-                      return $id:(funName $ fname<>"_extern")(+                      return $id:(funName (fname<>"_extern"))(                         $args:extra_exp,                         $args:out_args_noderef,                         $args:in_args_noderef);

@@ -16,8 +16,8 @@ import Futhark.CodeGen.RTS.Python (openclPy) import Futhark.IR.GPUMem (GPUMem, Prog) import Futhark.MonadFreshNames-import Futhark.Util (zEncodeString)-import Futhark.Util.Pretty (prettyString)+import Futhark.Util (zEncodeText)+import Futhark.Util.Pretty (prettyString, prettyText)  -- | Compile the program to Python with calls to OpenCL. compileProg ::@@ -45,8 +45,8 @@             ( \x ->                 prettyString $                   Assign-                    (Var ("self." ++ zEncodeString (nameToString x) ++ "_var"))-                    (Var $ "program." ++ zEncodeString (nameToString x))+                    (Var (T.unpack ("self." <> zEncodeText (nameToText x) <> "_var")))+                    (Var $ T.unpack $ "program." <> zEncodeText (nameToText x))             )           $ M.keys kernels @@ -201,7 +201,7 @@  kernelConstToExp :: Imp.KernelConst -> PyExp kernelConstToExp (Imp.SizeConst key) =-  Index (Var "self.sizes") (IdxExp $ String $ prettyString key)+  Index (Var "self.sizes") (IdxExp $ String $ prettyText key) kernelConstToExp (Imp.SizeMaxConst size_class) =   Var $ "self.max_" <> prettyString size_class @@ -249,7 +249,7 @@ launchKernel kernel_name safety kernel_dims workgroup_dims args = do   let kernel_dims' = Tuple kernel_dims       workgroup_dims' = Tuple workgroup_dims-      kernel_name' = "self." ++ zEncodeString (nameToString kernel_name) ++ "_var"+      kernel_name' = "self." <> zEncodeText (nameToText kernel_name) <> "_var"   args' <- mapM processKernelArg args   let failure_args =         take@@ -260,13 +260,13 @@           ]   Py.stm $     Exp $-      Py.simpleCall (kernel_name' ++ ".set_args") $+      Py.simpleCall (T.unpack $ kernel_name' <> ".set_args") $         failure_args ++ args'   Py.stm $     Exp $       Py.simpleCall         "cl.enqueue_nd_range_kernel"-        [Var "self.queue", Var kernel_name', kernel_dims', workgroup_dims']+        [Var "self.queue", Var (T.unpack kernel_name'), kernel_dims', workgroup_dims']   finishIfSynchronous   where     processKernelArg :: Imp.KernelArg -> Py.CompilerM op s PyExp@@ -326,7 +326,7 @@ allocateOpenCLBuffer mem size "device" =   Py.stm $     Assign mem $-      Py.simpleCall "opencl_alloc" [Var "self", size, String $ prettyString mem]+      Py.simpleCall "opencl_alloc" [Var "self", size, String $ prettyText mem] allocateOpenCLBuffer _ _ space =   error $ "Cannot allocate in '" ++ space ++ "' space" 

@@ -65,13 +65,13 @@  formatFailure :: FailureMsg -> PyExp formatFailure (FailureMsg (ErrorMsg parts) backtrace) =-  String $ concatMap onPart parts ++ "\n" ++ formatEscape backtrace+  String $ mconcat (map onPart parts) <> "\n" <> formatEscape backtrace   where     formatEscape =       let escapeChar '{' = "{{"           escapeChar '}' = "}}"-          escapeChar c = [c]-       in concatMap escapeChar+          escapeChar c = T.singleton c+       in mconcat . map escapeChar      onPart (ErrorString s) = formatEscape $ T.unpack s     onPart ErrorVal {} = "{}"@@ -80,9 +80,9 @@ sizeClassesToPython = Dict . map f . M.toList   where     f (size_name, size_class) =-      ( String $ prettyString size_name,+      ( String $ prettyText size_name,         Dict-          [ (String "class", String $ prettyString size_class),+          [ (String "class", String $ prettyText size_class),             ( String "value",               maybe None (Integer . fromIntegral) $                 sizeDefault size_class@@ -95,7 +95,7 @@   where     f (SizeHeuristic platform_name device_type which what) =       Tuple-        [ String platform_name,+        [ String (T.pack platform_name),           clDeviceType device_type,           which',           what'@@ -122,4 +122,4 @@           pure $             Py.simpleCall               "device.get_info"-              [Py.simpleCall "getattr" [Var "cl.device_info", String s]]+              [Py.simpleCall "getattr" [Var "cl.device_info", String (T.pack s)]]

@@ -76,6 +76,7 @@                           typename lock_t error_lock;                           typename FILE *log;                           int profiling_paused;+                          struct free_list free_list;                           $sdecls:fields                         };|]     )@@ -96,9 +97,8 @@                                   ctx->profiling = cfg->debugging;                                   ctx->logging = cfg->debugging;                                   ctx->error = NULL;-                                  create_lock(&ctx->error_lock);                                   ctx->log = stderr;-                                  create_lock(&ctx->lock);+                                  context_setup(ctx);                                   $stms:init_fields                                   init_constants(ctx);                                   return ctx;@@ -109,8 +109,7 @@     ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],       [C.cedecl|void $id:s(struct $id:ctx* ctx) {                                  $stms:free_fields-                                 free_constants(ctx);-                                 free_lock(&ctx->lock);+                                 context_teardown(ctx);                                  ctx->cfg->in_use = 0;                                  free(ctx);                                }|]

@@ -39,7 +39,7 @@ import Data.Text qualified as T import Futhark.CodeGen.ImpCode import Futhark.CodeGen.RTS.C (scalarF16H, scalarH)-import Futhark.Util (zEncodeString)+import Futhark.Util (zEncodeText) import Language.C.Quote.C qualified as C import Language.C.Syntax qualified as C import Text.Printf@@ -96,34 +96,36 @@  -- | @funName f@ is the name of the C function corresponding to -- the Futhark function @f@.-funName :: Name -> String-funName = ("futrts_" ++) . zEncodeString . nameToString+funName :: Name -> T.Text+funName = ("futrts_" <>) . zEncodeText . nameToText  -- | The type of memory blocks in the default memory space. defaultMemBlockType :: C.Type defaultMemBlockType = [C.cty|unsigned char*|]  -- | The name of exposed array type structs.-arrayName :: PrimType -> Signedness -> Int -> String+arrayName :: PrimType -> Signedness -> Int -> T.Text arrayName pt signed rank =-  prettySigned (signed == Unsigned) pt ++ "_" ++ show rank ++ "d"+  prettySigned (signed == Unsigned) pt <> "_" <> prettyText rank <> "d"  -- | The name of exposed opaque types.-opaqueName :: String -> String+opaqueName :: Name -> T.Text opaqueName "()" = "opaque_unit" -- Hopefully this ad-hoc convenience won't bite us. opaqueName s-  | valid = "opaque_" ++ s+  | valid = "opaque_" <> s'   where+    s' = nameToText s     valid =-      head s /= '_'-        && not (isDigit $ head s)-        && all ok s+      T.head s' /= '_'+        && not (isDigit $ T.head s')+        && T.all ok s'     ok c = isAlphaNum c || c == '_'-opaqueName s = "opaque_" ++ hash (zipWith xor [0 ..] $ map ord s)+opaqueName s = "opaque_" <> hash (zipWith xor [0 ..] $ map ord (nameToString s))   where     -- FIXME: a stupid hash algorithm; may have collisions.     hash =-      printf "%x"+      T.pack+        . printf "%x"         . foldl xor 0         . map           ( iter@@ -169,14 +171,14 @@     mult x y = [C.cexp|$exp:x + $exp:y|]  instance C.ToIdent Name where-  toIdent = C.toIdent . zEncodeString . nameToString+  toIdent = C.toIdent . zEncodeText . nameToText  -- Orphan! instance C.ToIdent T.Text where   toIdent = C.toIdent . T.unpack  instance C.ToIdent VName where-  toIdent = C.toIdent . zEncodeString . prettyString+  toIdent = C.toIdent . zEncodeText . prettyText  instance C.ToExp VName where   toExp v _ = [C.cexp|$id:v|]

@@ -193,7 +193,7 @@ data ExternalValue   = -- | The string is a human-readable description with no other     -- semantics.-    OpaqueValue String [ValueDesc]+    OpaqueValue Name [ValueDesc]   | TransparentValue ValueDesc   deriving (Show) 

@@ -494,7 +494,7 @@     extract s =       (mempty, s) -lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType+lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType lookupOpaqueType v (OpaqueTypes types) =   case lookup v types of     Just t -> t@@ -946,13 +946,10 @@   copy (elemType (patElemType pe)) (flatSliceMemLoc pe_loc slice') v_loc   where     slice' = fmap pe64 slice-defCompileBasicOp (Pat [pe]) (Replicate (Shape ds) se)+defCompileBasicOp (Pat [pe]) (Replicate shape se)   | Acc {} <- patElemType pe = pure ()-  | otherwise = do-      ds' <- mapM toExp ds-      is <- replicateM (length ds) (newVName "i")-      copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.le64) is) se []-      emit $ foldl (.) id (zipWith Imp.For is ds') copy_elem+  | otherwise =+      sLoopNest shape $ \is -> copyDWIMFix (patElemName pe) is se [] defCompileBasicOp _ Scratch {} =   pure () defCompileBasicOp (Pat [pe]) (Iota n e s it) = do

@@ -26,7 +26,7 @@ import Futhark.CodeGen.RTS.C (atomicsH, halfH) import Futhark.Error (compilerLimitationS) import Futhark.MonadFreshNames-import Futhark.Util (zEncodeString)+import Futhark.Util (zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C import NeatInterpolation (untrimming)@@ -289,9 +289,9 @@ isConst (Left (ValueExp (IntValue x))) =   Just $ prettyText $ intToInt64 x isConst (Right (SizeConst v)) =-  Just $ T.pack $ zEncodeString $ nameToString v+  Just $ zEncodeText $ nameToText v isConst (Right (SizeMaxConst size_class)) =-  Just $ T.pack $ "max_" <> prettyString size_class+  Just $ "max_" <> prettyText size_class isConst _ = Nothing  onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL@@ -458,7 +458,7 @@  useAsParam :: KernelUse -> Maybe (C.Param, [C.BlockItem]) useAsParam (ScalarUse name pt) = do-  let name_bits = zEncodeString (prettyString name) <> "_bits"+  let name_bits = zEncodeText (prettyText name) <> "_bits"       ctp = case pt of         -- OpenCL does not permit bool as a kernel parameter type.         Bool -> [C.cty|unsigned char|]@@ -647,7 +647,7 @@ compilePrimExp e = runIdentity $ GC.compilePrimExp compileKernelConst e   where     compileKernelConst (SizeConst key) =-      pure [C.cexp|$id:(zEncodeString (prettyString key))|]+      pure [C.cexp|$id:(zEncodeText (prettyText key))|]     compileKernelConst (SizeMaxConst size_class) =       pure [C.cexp|$id:("max_" <> prettyString size_class)|] 

@@ -21,38 +21,44 @@ import Futhark.Util.IntegralExp (rem) import Prelude hiding (quot, rem) --- GCC supported primitve atomic Operations--- TODO: Add support for 1, 2, and 16 bytes too-gccAtomics :: AtomicBinOp-gccAtomics = flip lookup cpu-  where-    cpu =-      [ (Add Int32 OverflowUndef, Imp.AtomicAdd Int32),-        (Sub Int32 OverflowUndef, Imp.AtomicSub Int32),-        (And Int32, Imp.AtomicAnd Int32),-        (Xor Int32, Imp.AtomicXor Int32),-        (Or Int32, Imp.AtomicOr Int32),-        (Add Int64 OverflowUndef, Imp.AtomicAdd Int64),-        (Sub Int64 OverflowUndef, Imp.AtomicSub Int64),-        (And Int64, Imp.AtomicAnd Int64),-        (Xor Int64, Imp.AtomicXor Int64),-        (Or Int64, Imp.AtomicOr Int64)-      ]+opCompiler :: OpCompiler MCMem HostEnv Imp.Multicore+opCompiler dest (Alloc e space) = compileAlloc dest e space+opCompiler dest (Inner op) = compileMCOp dest op --- | Compile the program.-compileProg ::-  MonadFreshNames m =>-  Prog MCMem ->-  m (Warnings, Imp.Definitions Imp.Multicore)-compileProg = Futhark.CodeGen.ImpGen.compileProg (HostEnv gccAtomics mempty) ops Imp.DefaultSpace+parallelCopy :: CopyCompiler MCMem HostEnv Imp.Multicore+parallelCopy pt destloc srcloc = do+  seq_code <- collect $ localOps inThreadOps $ do+    body <- genCopy+    free_params <- freeParams body+    emit $ Imp.Op $ Imp.ParLoop "copy" body free_params+  free_params <- freeParams seq_code+  s <- prettyString <$> newVName "copy"+  iterations <- dPrimVE "iterations" $ product $ map pe64 srcshape+  let scheduling = Imp.SchedulerInfo (untyped iterations) Imp.Static+  emit . Imp.Op $+    Imp.SegOp s free_params (Imp.ParallelTask seq_code) Nothing [] scheduling   where-    ops =-      (defaultOperations opCompiler)-        { opsExpCompiler = compileMCExp-        }-    opCompiler dest (Alloc e space) = compileAlloc dest e space-    opCompiler dest (Inner op) = compileMCOp dest op+    MemLoc destmem _ _ = destloc+    MemLoc srcmem srcshape _ = srcloc+    genCopy = collect . inISPC . generateChunkLoop "copy" Vectorized $ \i -> do+      is <- dIndexSpace' "i" (map pe64 srcshape) i+      (_, destspace, destidx) <- fullyIndexArray' destloc is+      (_, srcspace, srcidx) <- fullyIndexArray' srcloc is+      tmp <- tvVar <$> dPrim "tmp" pt+      emit $ Imp.Read tmp srcmem srcidx pt srcspace Imp.Nonvolatile+      emit $ Imp.Write destmem destidx pt destspace Imp.Nonvolatile $ Imp.var tmp pt +topLevelOps, inThreadOps :: Operations MCMem HostEnv Imp.Multicore+inThreadOps =+  (defaultOperations opCompiler)+    { opsExpCompiler = compileMCExp+    }+topLevelOps =+  (defaultOperations opCompiler)+    { opsExpCompiler = compileMCExp,+      opsCopyCompiler = parallelCopy+    }+ updateAcc :: VName -> [SubExp] -> [SubExp] -> MulticoreGen () updateAcc acc is vs = sComment "UpdateAcc" $ do   -- See the ImpGen implementation of UpdateAcc for general notes.@@ -124,7 +130,7 @@   let space = getSpace op   dPrimV_ (segFlat space) (0 :: Imp.TExp Int64)   iterations <- getIterationDomain op space-  seq_code <- collect $ do+  seq_code <- collect $ localOps inThreadOps $ do     nsubtasks <- dPrim "nsubtasks" int32     sOp $ Imp.GetNumTasks $ tvVar nsubtasks     emit =<< compileSegOp pat op nsubtasks@@ -163,3 +169,32 @@   compileSegRed pat space reds kbody ntasks compileSegOp pat (SegMap _ space _ kbody) _ =   compileSegMap pat space kbody++-- GCC supported primitve atomic Operations+-- TODO: Add support for 1, 2, and 16 bytes too+gccAtomics :: AtomicBinOp+gccAtomics = flip lookup cpu+  where+    cpu =+      [ (Add Int32 OverflowUndef, Imp.AtomicAdd Int32),+        (Sub Int32 OverflowUndef, Imp.AtomicSub Int32),+        (And Int32, Imp.AtomicAnd Int32),+        (Xor Int32, Imp.AtomicXor Int32),+        (Or Int32, Imp.AtomicOr Int32),+        (Add Int64 OverflowUndef, Imp.AtomicAdd Int64),+        (Sub Int64 OverflowUndef, Imp.AtomicSub Int64),+        (And Int64, Imp.AtomicAnd Int64),+        (Xor Int64, Imp.AtomicXor Int64),+        (Or Int64, Imp.AtomicOr Int64)+      ]++-- | Compile the program.+compileProg ::+  MonadFreshNames m =>+  Prog MCMem ->+  m (Warnings, Imp.Definitions Imp.Multicore)+compileProg =+  Futhark.CodeGen.ImpGen.compileProg+    (HostEnv gccAtomics mempty)+    topLevelOps+    Imp.DefaultSpace

@@ -53,7 +53,7 @@ import Language.Futhark.TypeChecker qualified as E import Language.Futhark.Warnings import System.Directory (getModificationTime)-import System.FilePath (normalise)+import System.FilePath (normalise, takeExtension) import System.FilePath.Posix qualified as Posix  data LoadedFile fm = LoadedFile@@ -231,26 +231,31 @@           Just prog_mvar -> pure (state, (include, prog_mvar))           Nothing -> do             prog_mvar <- newImportMVar $ do-              r <- contentsAndModTime fp vfs-              case r of-                Just (Right (fs, mod_time)) -> do-                  handleFile state_mvar vfs $-                    LoadedFile-                      { lfImportName = include,-                        lfMod = fs,-                        lfModTime = mod_time,-                        lfPath = fp-                      }-                Just (Left e) ->-                  pure . UncheckedImport . Left . NE.singleton $-                    ProgError NoLoc $-                      pretty $-                        show e-                Nothing ->+              if takeExtension fp /= ".fut"+                then                   pure . UncheckedImport . Left . NE.singleton $                     ProgError NoLoc $-                      pretty $-                        fp <> ": file not found."+                      pretty fp <> ": source files must have a .fut extension."+                else do+                  r <- contentsAndModTime fp vfs+                  case r of+                    Just (Right (fs, mod_time)) -> do+                      handleFile state_mvar vfs $+                        LoadedFile+                          { lfImportName = include,+                            lfMod = fs,+                            lfModTime = mod_time,+                            lfPath = fp+                          }+                    Just (Left e) ->+                      pure . UncheckedImport . Left . NE.singleton $+                        ProgError NoLoc $+                          pretty $+                            show e+                    Nothing ->+                      pure . UncheckedImport . Left . NE.singleton $+                        ProgError NoLoc $+                          pretty fp <> ": file not found."             pure (M.insert include prog_mvar state, (include, prog_mvar))       where         include = mkInitialImport fp_name

@@ -600,7 +600,7 @@ pEntryPointType :: Parser EntryPointType pEntryPointType =   choice-    [ keyword "opaque" $> TypeOpaque . T.unpack <*> pStringLiteral,+    [ keyword "opaque" $> TypeOpaque . nameFromText <*> pStringLiteral,       TypeTransparent <$> pValueType     ] @@ -635,10 +635,10 @@   FunDef entry attrs fname ret fparams     <$> (pEqual *> braces (pBody pr)) -pOpaqueType :: Parser (String, OpaqueType)+pOpaqueType :: Parser (Name, OpaqueType) pOpaqueType =   (,)-    <$> (keyword "type" *> (T.unpack <$> pStringLiteral) <* pEqual)+    <$> (keyword "type" *> (nameFromText <$> pStringLiteral) <* pEqual)     <*> choice [pRecord, pOpaque]   where     pFieldName = choice [pName, nameFromString . show <$> pInt]

@@ -744,31 +744,32 @@ arrayOps ::   forall rep.   (Buildable rep, HasSOAC rep) =>+  Certs ->   Body rep ->   S.Set (Pat (LetDec rep), ArrayOp)-arrayOps = mconcat . map onStm . stmsToList . bodyStms+arrayOps cs = mconcat . map onStm . stmsToList . bodyStms   where     onStm (Let pat aux e) =-      case isArrayOp (stmAuxCerts aux) e of+      case isArrayOp (cs <> stmAuxCerts aux) e of         Just op -> S.singleton (pat, op)-        Nothing -> execState (walkExpM walker e) mempty-    onOp op+        Nothing -> execState (walkExpM (walker (stmAuxCerts aux)) e) mempty+    onOp more_cs op       | Just soac <- asSOAC op =           -- Copies are not safe to move out of nested ops (#1753).           S.filter (notCopy . snd) $             execWriter $               mapSOACM-                identitySOACMapper {mapOnSOACLambda = onLambda}+                identitySOACMapper {mapOnSOACLambda = onLambda more_cs}                 (soac :: SOAC rep)       | otherwise =           mempty-    onLambda lam = do-      tell $ arrayOps $ lambdaBody lam+    onLambda more_cs lam = do+      tell $ arrayOps (cs <> more_cs) $ lambdaBody lam       pure lam-    walker =+    walker more_cs =       identityWalker-        { walkOnBody = const $ modify . (<>) . arrayOps,-          walkOnOp = modify . (<>) . onOp+        { walkOnBody = const $ modify . (<>) . arrayOps (cs <> more_cs),+          walkOnOp = modify . (<>) . onOp more_cs         }     notCopy (ArrayCopy {}) = False     notCopy _ = True@@ -827,7 +828,7 @@     Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs),     indexings <-       mapMaybe (indexesWith (paramName p)) . S.toList $-        arrayOps $+        arrayOps mempty $           lambdaBody map_lam,     not $ null indexings = Simplify $ do       -- For each indexing with iota, add the corresponding array to@@ -896,7 +897,7 @@ -- full array. moveTransformToInput :: TopDownRuleOp (Wise SOACS) moveTransformToInput vtable screma_pat aux soac@(Screma w arrs (ScremaForm scan reduce map_lam))-  | ops <- filter arrayIsMapParam $ S.toList $ arrayOps $ lambdaBody map_lam,+  | ops <- filter arrayIsMapParam $ S.toList $ arrayOps mempty $ lambdaBody map_lam,     not $ null ops = Simplify $ do       (more_arrs, more_params, replacements) <-         unzip3 . catMaybes <$> mapM mapOverArr ops

@@ -584,7 +584,7 @@ -- indicating how it maps to the original source program type. data EntryPointType   = -- | An opaque type of this name.-    TypeOpaque String+    TypeOpaque Name   | -- | A transparent type, which is scalar if the rank is zero.     TypeTransparent ValueType   deriving (Eq, Show, Ord)@@ -598,7 +598,7 @@   deriving (Eq, Ord, Show)  -- | Names of opaque types and their representation.-newtype OpaqueTypes = OpaqueTypes [(String, OpaqueType)]+newtype OpaqueTypes = OpaqueTypes [(Name, OpaqueType)]   deriving (Eq, Ord, Show)  instance Monoid OpaqueTypes where

@@ -564,7 +564,7 @@     checkEntryPointType known (TypeOpaque s) =       when (s `notElem` known) $         Left . Error [] . TypeError $-          "Opaque not defined before first use: " <> T.pack s+          "Opaque not defined before first use: " <> nameToText s     checkEntryPointType _ (TypeTransparent _) = pure ()  -- | Type check a program containing arbitrary type information,

@@ -9,12 +9,11 @@ import Control.Monad.State import Data.List (find) import Data.Map qualified as M-import Data.Text qualified as T import Futhark.IR qualified as I import Futhark.Internalise.TypesValues (internalisedTypeSize)-import Futhark.Util.Pretty (prettyTextOneLine)+import Futhark.Util.Pretty (prettyText, prettyTextOneLine) import Language.Futhark qualified as E hiding (TypeArg)-import Language.Futhark.Core (Name, Uniqueness (..), VName)+import Language.Futhark.Core (Name, Uniqueness (..), VName, nameFromText) import Language.Futhark.Semantic qualified as E  -- | The types that are visible to the outside world.@@ -51,20 +50,20 @@ rootType (E.TEUnique te _) = rootType te rootType te = te -typeExpOpaqueName :: E.TypeExp VName -> String+typeExpOpaqueName :: E.TypeExp VName -> Name typeExpOpaqueName = f . rootType   where     f (E.TEArray _ te _) =       let (d, te') = withoutDims te-       in "arr_" <> typeExpOpaqueName te' <> "_" <> show (1 + d) <> "d"-    f te = T.unpack $ prettyTextOneLine te+       in "arr_" <> typeExpOpaqueName te' <> "_" <> nameFromText (prettyText (1 + d)) <> "d"+    f te = nameFromText $ prettyTextOneLine te  type GenOpaque = State I.OpaqueTypes  runGenOpaque :: GenOpaque a -> (a, I.OpaqueTypes) runGenOpaque = flip runState mempty -addType :: String -> I.OpaqueType -> GenOpaque ()+addType :: Name -> I.OpaqueType -> GenOpaque () addType s t = modify (<> I.OpaqueTypes [(s, t)])  isRecord :: VisibleTypes -> E.TypeExp VName -> Maybe (M.Map Name (E.TypeExp VName))@@ -129,7 +128,7 @@   where     u = foldl max Nonunique $ map I.uniqueness ts     desc =-      maybe (T.unpack $ prettyTextOneLine t') typeExpOpaqueName $+      maybe (nameFromText $ prettyTextOneLine t') typeExpOpaqueName $         E.entryAscribed t     t' = E.noSizes (E.entryType t) `E.setUniqueness` Nonunique 

@@ -13,22 +13,6 @@ import Language.LSP.Types import Language.LSP.Types.Lens (HasUri (uri)) --- | Given an 'IORef' tracking the state, produce a set of handlers.--- When we want to add more features to the language server, this is--- the thing to change.-handlers :: IORef State -> Handlers (LspM ())-handlers state_mvar =-  mconcat-    [ onInitializeHandler,-      onDocumentOpenHandler state_mvar,-      onDocumentCloseHandler,-      onDocumentSaveHandler state_mvar,-      onDocumentChangeHandler state_mvar,-      onDocumentFocusHandler state_mvar,-      goToDefinitionHandler state_mvar,-      onHoverHandler state_mvar-    ]- onInitializeHandler :: Handlers (LspM ()) onInitializeHandler = notificationHandler SInitialized $ \_msg ->   logStringStderr <& "Initialized"@@ -83,3 +67,28 @@ onDocumentCloseHandler :: Handlers (LspM ()) onDocumentCloseHandler = notificationHandler STextDocumentDidClose $ \_msg ->   logStringStderr <& "Closed document"++-- Sent by Eglot when first connecting - not sure when else it might+-- be sent.+onWorkspaceDidChangeConfiguration :: IORef State -> Handlers (LspM ())+onWorkspaceDidChangeConfiguration _state_mvar =+  notificationHandler SWorkspaceDidChangeConfiguration $ \msg -> do+    let NotificationMessage _ _ (DidChangeConfigurationParams _settings) = msg+    logStringStderr <& "WorkspaceDidChangeConfiguration"++-- | Given an 'IORef' tracking the state, produce a set of handlers.+-- When we want to add more features to the language server, this is+-- the thing to change.+handlers :: IORef State -> Handlers (LspM ())+handlers state_mvar =+  mconcat+    [ onInitializeHandler,+      onDocumentOpenHandler state_mvar,+      onDocumentCloseHandler,+      onDocumentSaveHandler state_mvar,+      onDocumentChangeHandler state_mvar,+      onDocumentFocusHandler state_mvar,+      goToDefinitionHandler state_mvar,+      onHoverHandler state_mvar,+      onWorkspaceDidChangeConfiguration state_mvar+    ]

@@ -128,18 +128,12 @@ simplifyIndex :: BuilderOps rep => BottomUpRuleBasicOp rep simplifyIndex (vtable, used) pat@(Pat [pe]) (StmAux cs attrs _) (Index idd inds)   | Just m <- simplifyIndexing vtable seType idd inds consumed = Simplify $ do-      res <- m+      res <- certifying cs m       attributing attrs $ case res of         SubExpResult cs' se ->-          certifying (cs <> cs') $-            letBindNames (patNames pat) $-              BasicOp $-                SubExp se+          certifying cs' $ letBindNames (patNames pat) $ BasicOp $ SubExp se         IndexResult extra_cs idd' inds' ->-          certifying (cs <> extra_cs) $-            letBindNames (patNames pat) $-              BasicOp $-                Index idd' inds'+          certifying extra_cs $ letBindNames (patNames pat) $ BasicOp $ Index idd' inds'   where     consumed = patElemName pe `UT.isConsumed` used     seType (Var v) = ST.lookupType v vtable

@@ -199,10 +199,10 @@                 thisbody <- mkBodyM thisstms [subExpRes thisres]                 (altres, altstms) <- collectStms $ mkBranch xs_and_starts'                 altbody <- mkBodyM altstms [subExpRes altres]-                letSubExp "index_concat_branch" $+                certifying cs . letSubExp "index_concat_branch" $                   Match [cmp] [Case [Just $ BoolValue True] thisbody] altbody $                     MatchDec [primBodyType res_t] MatchNormal-          SubExpResult cs <$> mkBranch xs_and_starts+          SubExpResult mempty <$> mkBranch xs_and_starts     Just (ArrayLit ses _, cs)       | DimFix (Constant (IntValue (Int64Value i))) : inds' <- inds,         Just se <- maybeNth i ses ->

@@ -29,7 +29,7 @@ import Data.Text.Encoding qualified as T import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Futhark.Pkg.Types-import Futhark.Util (maybeHead)+import Futhark.Util (maybeHead, showText) import Futhark.Util.Log import System.Exit import System.FilePath.Posix qualified as Posix@@ -450,11 +450,11 @@                 | (_, vs) <- majorRevOfPkg p,                   _svMajor v `notElem` vs =                     "\nFor major version "-                      <> T.pack (show (_svMajor v))+                      <> showText (_svMajor v)                       <> ", use package path "                       <> p                       <> "@"-                      <> T.pack (show (_svMajor v))+                      <> showText (_svMajor v)                 | otherwise = mempty            in fail $                 T.unpack $

@@ -47,7 +47,7 @@ import Futhark.Server.Values import Futhark.Test.Spec import Futhark.Test.Values qualified as V-import Futhark.Util (isEnvVarAtLeast, pmapIO)+import Futhark.Util (isEnvVarAtLeast, pmapIO, showText) import Futhark.Util.Pretty (prettyText, prettyTextOneLine) import System.Directory import System.Exit@@ -190,7 +190,7 @@       s <- liftIO $ readAndDecompress $ dir </> file       case s of         Left e ->-          throwError $ T.pack $ show file <> ": " <> show e+          throwError $ showText file <> ": " <> showText e         Right s' ->           cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do             BS.hPutStr tmpf_h s'@@ -497,7 +497,7 @@           <> " and "           <> T.pack expectedf           <> " do not match:\n"-          <> T.pack (show mismatch)+          <> showText mismatch           <> if null mismatches             then mempty             else "\n...and " <> prettyText (length mismatches) <> " other mismatches."

@@ -27,6 +27,7 @@     focusNth,     focusMaybe,     hashText,+    showText,     unixEnvironment,     isEnvVarAtLeast,     startupTime,@@ -40,9 +41,9 @@     pmapIO,     interactWithFileSafely,     convFloat,-    UserString,-    EncodedString,-    zEncodeString,+    UserText,+    EncodedText,+    zEncodeText,     atMostChars,     invertMap,     cartesian,@@ -212,6 +213,10 @@ hashText =   T.decodeUtf8With T.lenientDecode . Base16.encode . MD5.hash . T.encodeUtf8 +-- | Like 'show', but produces text.+showText :: Show a => a -> T.Text+showText = T.pack . show+ {-# NOINLINE unixEnvironment #-}  -- | The Unix environment when the Futhark compiler started.@@ -356,12 +361,22 @@ -- | Encoded form. type EncodedString = String --- | Z-encode a string using a slightly simplified variant of GHC--- Z-encoding.  The encoded string is a valid identifier in most--- programming languages.+-- | As 'zEncodeText', but for strings. zEncodeString :: UserString -> EncodedString zEncodeString "" = "" zEncodeString (c : cs) = encodeDigitChar c ++ concatMap encodeChar cs++-- | As the user typed it.+type UserText = T.Text++-- | Encoded form.+type EncodedText = T.Text++-- | Z-encode a text using a slightly simplified variant of GHC+-- Z-encoding.  The encoded string is a valid identifier in most+-- programming languages.+zEncodeText :: UserText -> EncodedText+zEncodeText = T.pack . zEncodeString . T.unpack  unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False

@@ -10,6 +10,7 @@  import Control.Monad.IO.Class import Data.List (sortBy)+import Data.Text.IO qualified as T import Futhark.Version import System.Console.GetOpt import System.Environment (getProgName)@@ -100,10 +101,10 @@   ]   where     header = do-      putStrLn $ "Futhark " ++ versionString-      putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."-      putStrLn "This is free software: you are free to change and redistribute it."-      putStrLn "There is NO WARRANTY, to the extent permitted by law."+      T.putStrLn $ "Futhark " <> versionString+      T.putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."+      T.putStrLn "This is free software: you are free to change and redistribute it."+      T.putStrLn "There is NO WARRANTY, to the extent permitted by law."  -- | Terminate the program with this error message (but don't report -- it as an ICE, as happens with 'error').

@@ -10,6 +10,7 @@  import Data.ByteString.Char8 qualified as BS import Data.FileEmbed+import Data.Text qualified as T import Data.Version import Futhark.Util (trim) import GitHash@@ -24,12 +25,10 @@  {-# NOINLINE versionString #-} --- | The version of Futhark that we are using, as a 'String'.-versionString :: String+-- | The version of Futhark that we are using, in human-readable form.+versionString :: T.Text versionString =-  showVersion version-    ++ unreleased-    ++ gitversion $$tGitInfoCwdTry+  T.pack (showVersion version) <> unreleased <> gitversion $$tGitInfoCwdTry   where     unreleased =       if last (versionBranch version) == 0@@ -38,22 +37,22 @@     gitversion (Left _) =       case commitIdFromFile of         Nothing -> ""-        Just commit -> "\ngit: " <> commit+        Just commit -> "\ngit: " <> T.pack commit     gitversion (Right gi) =-      concat+      mconcat         [ "\n",           "git: ",           branch,-          take 7 $ giHash gi,+          T.pack (take 7 $ giHash gi),           " (",-          giCommitDate gi,+          T.pack (giCommitDate gi),           ")",           dirty         ]       where         branch           | giBranch gi == "master" = ""-          | otherwise = giBranch gi ++ " @ "+          | otherwise = T.pack (giBranch gi) <> " @ "         dirty = if giDirty gi then " [modified]" else ""  commitIdFromFile :: Maybe String

@@ -45,6 +45,7 @@ import Data.String import Data.Text qualified as T import Data.Word (Word16, Word32, Word64, Word8)+import Futhark.Util (showText) import Futhark.Util.Loc import Futhark.Util.Pretty import Numeric.Half@@ -155,7 +156,7 @@     f i x =       (if cur == i then "-> " else "   ")         <> "#"-        <> T.pack (show i)+        <> showText i         <> (if i > 9 then "" else " ")         <> " "         <> x

@@ -16,12 +16,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8) import Data.Loc (Loc (..), L(..), Pos(..))-import Data.Bits import Data.Function (fix)-import Data.List-import Data.Monoid-import Data.Either-import Numeric.Half  import Language.Futhark.Core (Int8, Int16, Int32, Int64,                               Word8, Word16, Word32, Word64,@@ -30,8 +25,6 @@ import Language.Futhark.Syntax (BinOp(..)) import Language.Futhark.Parser.Lexer.Wrapper import Language.Futhark.Parser.Lexer.Tokens-import qualified Data.ByteString.Internal as ByteString (w2c)-import qualified Data.ByteString.Lazy as ByteString  } @@ -47,7 +40,8 @@  @field = [a-zA-Z0-9] [a-zA-Z0-9_]* -@identifier = [a-zA-Z] [a-zA-Z0-9_']* | "_" [a-zA-Z0-9] [a-zA-Z0-9_']*+@constituent = [a-zA-Z0-9_']+@identifier = [a-zA-Z] @constituent* | "_" [a-zA-Z0-9] @constituent* @qualidentifier = (@identifier ".")+ @identifier  $opchar = [\+\-\*\/\%\=\!\>\<\|\&\^\.]@@ -68,7 +62,9 @@   "="                      { tokenC EQU }   "("                      { tokenC LPAR }   ")"                      { tokenC RPAR }-  ")["                     { tokenC RPAR_THEN_LBRACKET }+  [a-zA-Z0-9_'] ^ "["      { tokenC INDEXING }+  \)            ^ "["      { tokenC INDEXING }+  \]            ^ "["      { tokenC INDEXING }   "["                      { tokenC LBRACKET }   "]"                      { tokenC RBRACKET }   "{"                      { tokenC LCURLY }@@ -95,6 +91,7 @@   "$"                      { tokenC DOLLAR }   "???"                    { tokenC HOLE } +  @declit                  { tokenS $ \s -> NATLIT (nameFromText s) (readIntegral s) }   @intlit i8               { tokenM $ pure . I8LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }   @intlit i16              { tokenM $ pure . I16LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }   @intlit i32              { tokenM $ pure . I32LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }@@ -105,10 +102,10 @@   @intlit u64              { tokenM $ pure . U64LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='u') }   @intlit                  { tokenM $ pure . INTLIT . readIntegral . T.filter (/= '_') } -  @reallit f16             { tokenM $ fmap F16LIT . tryRead "f16" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }-  @reallit f32             { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }-  @reallit f64             { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }-  @reallit                 { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') }+  [^\.] ^ @reallit f16     { tokenM $ fmap F16LIT . tryRead "f16" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }+  [^\.] ^ @reallit f32     { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }+  [^\.] ^ @reallit f64     { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') }+  [^\.] ^ @reallit         { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') }   @hexreallit f16          { tokenM $ fmap F16LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 }   @hexreallit f32          { tokenM $ fmap F32LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 }   @hexreallit f64          { tokenM $ fmap F64LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 }@@ -117,16 +114,10 @@   \" @stringcharlit* \"    { tokenM $ fmap (STRINGLIT . T.pack) . tryRead "string"  }    @identifier              { tokenS keyword }-  @identifier "["          { tokenPosM $ fmap INDEXING . indexing . second (T.takeWhile (/='[')) }-  @qualidentifier "["      { tokenM $ fmap (uncurry QUALINDEXING) . mkQualId . T.takeWhile (/='[') }-  @identifier "." "("      { tokenPosM $ fmap (QUALPAREN []) . indexing . second (T.init . T.takeWhile (/='(')) }-  @qualidentifier "." "("  { tokenM $ fmap (uncurry QUALPAREN) . mkQualId . T.init . T.takeWhile (/='(') }   "#" @identifier          { tokenS $ CONSTRUCTOR . nameFromText . T.drop 1 }    @binop                   { tokenM $ pure . symbol [] . nameFromText }   @qualbinop               { tokenM $ \s -> do (qs,k) <- mkQualId s; pure (symbol qs k) }--  "." [0-9]+               { tokenS $ PROJ_INTFIELD . nameFromText . T.drop 1 } {  getToken :: Alex (Lexeme Token)

@@ -53,12 +53,10 @@ data Token   = ID Name   | COMMENT T.Text-  | INDEXING Name-  | QUALINDEXING [Name] Name-  | QUALPAREN [Name] Name+  | INDEXING -- A left bracket immediately following an identifier.   | SYMBOL BinOp [Name] Name   | CONSTRUCTOR Name-  | PROJ_INTFIELD Name+  | NATLIT Name Integer   | INTLIT Integer   | STRINGLIT T.Text   | I8LIT Int8@@ -89,7 +87,6 @@   | THREE_DOTS   | LPAR   | RPAR-  | RPAR_THEN_LBRACKET   | LBRACKET   | RBRACKET   | LCURLY

@@ -9,6 +9,7 @@   ( runAlex,     Alex,     AlexInput,+    alexInputPrevChar,     Byte,     LexerError (..),     alexSetInput,@@ -45,6 +46,9 @@     BS.ByteString, -- current input string     Int64 -- bytes consumed so far   )++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_, prev, _, _) = prev  {-# INLINE alexGetByte #-} alexGetByte :: AlexInput -> Maybe (Byte, AlexInput)

@@ -65,16 +65,11 @@       case            { L $$ CASE }        id              { L _ (ID _) }-      'id['           { L _ (INDEXING _) }--      'qid['          { L _ (QUALINDEXING _ _) }--      'qid.('         { L _ (QUALPAREN _ _) }+      '...['          { L _ INDEXING }        constructor     { L _ (CONSTRUCTOR _) } -      '.int'          { L _ (PROJ_INTFIELD _) }-+      natlit          { L _ (NATLIT _ _) }       intlit          { L _ (INTLIT _) }       i8lit           { L _ (I8LIT _) }       i16lit          { L _ (I16LIT _) }@@ -132,7 +127,6 @@        '('             { L $$ LPAR }       ')'             { L $$ RPAR }-      ')['            { L $$ RPAR_THEN_LBRACKET }       '{'             { L $$ LCURLY }       '}'             { L $$ RCURLY }       '['             { L $$ LBRACKET }@@ -308,9 +302,6 @@       | type Liftedness id TypeParams         { let L _ (ID name) = $3           in TypeSpec $2 name $4 Nothing (srcspan $1 $>) }-      | type Liftedness 'id[' id ']' TypeParams-        { let L _ (INDEXING name) = $3; L ploc (ID pname) = $4-          in TypeSpec $2 name (TypeParamDim pname (srclocOf ploc) : $6) Nothing (srcspan $1 $>) }        | module id ':' SigExp         { let L _ (ID name) = $2@@ -327,22 +318,37 @@        |            { [] }  SizeBinder :: { SizeBinder Name }-            : '[' id ']' { let L _ (ID name) = $2 in SizeBinder name (srcspan $1 $>) }+            : '[' id ']'  { let L _ (ID name) = $2 in SizeBinder name (srcspan $1 $>) }+            | '...[' id ']' { let L _ (ID name) = $2 in SizeBinder name (srcspan $1 $>) }  SizeBinders1 :: { [SizeBinder Name] }              : SizeBinder SizeBinders1 { $1 : $2 }              | SizeBinder              { [$1] } -TypeParam :: { TypeParamBase Name }-           : '[' id ']' { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) }-           | '\'' id { let L _ (ID name) = $2 in TypeParamType Unlifted name (srcspan $1 $>) }+TypeTypeParam :: { TypeParamBase Name }+           : '\'' id { let L _ (ID name) = $2 in TypeParamType Unlifted name (srcspan $1 $>) }            | '\'~' id { let L _ (ID name) = $2 in TypeParamType SizeLifted name (srcspan $1 $>) }            | '\'^' id { let L _ (ID name) = $2 in TypeParamType Lifted name (srcspan $1 $>) } +TypeParam :: { TypeParamBase Name }+           : '[' id ']' { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) }+           | '...[' id ']' { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) }+           | TypeTypeParam { $1 }+ TypeParams :: { [TypeParamBase Name] }             : TypeParam TypeParams { $1 : $2 }             |                      { [] } +-- Due to an ambiguity between in-place updates ("let x[i] ...") and+-- local functions with size parameters, the latter need a special+-- nonterminal.+LocalFunTypeParams :: { [TypeParamBase Name] }+                    : '[' id ']' TypeParams+                      { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) : $4 }+                    | TypeTypeParam TypeParams { $1 : $2 }+                    |                          { [] }++ -- Note that this production does not include Minus, but does include -- operator sections. BinOp :: { (QualName Name, Loc) }@@ -431,9 +437,6 @@ TypeAbbr : type Liftedness id TypeParams '=' TypeExp            { let L _ (ID name) = $3               in TypeBind name $2 $4 $6 NoInfo Nothing (srcspan $1 $>) }-         | type Liftedness 'id[' id ']' TypeParams '=' TypeExp-           { let L loc (INDEXING name) = $3; L ploc (ID pname) = $4-             in TypeBind name $2 (TypeParamDim pname (srclocOf ploc):$6) $8 NoInfo Nothing (srcspan $1 $>) }  TypeExp :: { UncheckedTypeExp }          : '(' id ':' TypeExp ')' '->' TypeExp@@ -446,13 +449,18 @@ TypeExpDims :: { [Name] }          : '[' id ']'             { let L _ (ID v) = $2 in [v] }          | '[' id ']' TypeExpDims { let L _ (ID v) = $2 in v : $4 }+         | '...[' id ']'             { let L _ (ID v) = $2 in [v] }+         | '...[' id ']' TypeExpDims { let L _ (ID v) = $2 in v : $4 }  TypeExpTerm :: { UncheckedTypeExp }          : '*' TypeExpTerm            { TEUnique $2 (srcspan $1 $>) }          | '[' SizeExp ']' TypeExpTerm %prec indexprec            { TEArray $2 $4 (srcspan $1 $>) }+         | '...[' SizeExp ']' TypeExpTerm %prec indexprec+           { TEArray $2 $4 (srcspan $1 $>) }          | TypeExpApply %prec sumprec { $1 }+         | SumType                    { $1 }           -- Errors          | '[' SizeExp ']' %prec bottom@@ -460,6 +468,11 @@                 T.unlines ["missing array row type.",                            "Did you mean []"  <> prettyText $2 <> "?"]            }+         | '...[' SizeExp ']' %prec bottom+           {% parseErrorAt (srcspan $1 $>) $ Just $+                T.unlines ["missing array row type.",+                           "Did you mean []"  <> prettyText $2 <> "?"]+           }  SumType :: { UncheckedTypeExp } SumType  : SumClauses %prec sumprec { let (cs, loc) = $1 in TESum cs (srclocOf loc) }@@ -480,16 +493,6 @@ TypeExpApply :: { UncheckedTypeExp }               : TypeExpApply TypeArg                 { TEApply $1 $2 (srcspan $1 $>) }-              | 'id[' SizeExp ']'-                { let L loc (INDEXING v) = $1-                  in TEApply (TEVar (qualName v) (srclocOf (backOneCol loc)))-                             (TypeArgExpDim $2 (srclocOf loc))-                             (srcspan $1 $>) }-              | 'qid[' SizeExp ']'-                { let L loc (QUALINDEXING qs v) = $1-                  in TEApply (TEVar (QualName qs v) (srclocOf (backOneCol loc)))-                             (TypeArgExpDim $2 (srclocOf loc))-                             (srcspan $1 $>) }               | TypeExpAtom                 { $1 } @@ -500,14 +503,14 @@              | '{' '}'                        { TERecord [] (srcspan $1 $>) }              | '{' FieldTypes1 '}'            { TERecord $2 (srcspan $1 $>) }              | QualName                       { TEVar (fst $1) (srclocOf (snd $1)) }-             | SumType                        { $1 }  Constr :: { (Name, Loc) }         : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, locOf $1) }  TypeArg :: { TypeArgExp Name }-         : '[' SizeExp ']' { TypeArgExpDim $2 (srcspan $1 $>) }-         | TypeExpAtom     { TypeArgExpType $1 }+         : '[' SizeExp ']'  { TypeArgExpDim $2 (srcspan $1 $>) }+         | '...[' SizeExp ']' { TypeArgExpDim $2 (srcspan $1 $>) }+         | TypeExpAtom      { TypeArgExpType $1 }  FieldType :: { (Name, UncheckedTypeExp) } FieldType : FieldId ':' TypeExp { (fst $1, $3) }@@ -526,6 +529,9 @@         | intlit           { let L loc (INTLIT n) = $1             in SizeExpConst (fromIntegral n) (srclocOf loc) }+        | natlit+          { let L loc (NATLIT _ n) = $1+            in SizeExpConst (fromIntegral n) (srclocOf loc) }         |           { SizeExpAny } @@ -541,15 +547,15 @@            | FunParam FunParams { $1 : $2 }  QualName :: { (QualName Name, Loc) }-          : id FieldAccesses-            { let L vloc (ID v) = $1 in-              foldl (\(QualName qs v', loc) (y, yloc) ->-                      (QualName (qs ++ [v']) y, locOf (srcspan loc yloc)))-                    (qualName v, locOf vloc) $2 }+          : id+            { let L vloc (ID v) = $1 in (QualName [] v, vloc) }+          | QualName '.' id+            { let {L ploc (ID f) = $3; (QualName qs v,vloc) = $1;}+              in (QualName (qs++[v]) f, locOf (srcspan ploc vloc)) }  -- Expressions are divided into several layers.  The first distinction -- (between Exp and Exp2) is to factor out ascription, which we do not--- permit inside array indices operations (there is an ambiguity with+-- permit inside array slices (there is an ambiguity with -- array slices). Exp :: { UncheckedExp }      : Exp ':' TypeExp  { Ascript $1 $3 (srcspan $1 $>) }@@ -575,6 +581,8 @@       | Exp2 with '[' DimIndices ']' '=' Exp2        { Update $1 $4 $7 (srcspan $1 $>) }+     | Exp2 with '...[' DimIndices ']' '=' Exp2+       { Update $1 $4 $7 (srcspan $1 $>) }       | Exp2 with FieldAccesses_ '=' Exp2        { RecordUpdate $1 (map fst $3) $5 NoInfo (srcspan $1 $>) }@@ -596,31 +604,39 @@      | charlit        { let L loc (CHARLIT x) = $1                         in IntLit (toInteger (ord x)) NoInfo (srclocOf loc) }      | intlit         { let L loc (INTLIT x) = $1 in IntLit x NoInfo (srclocOf loc) }+     | natlit         { let L loc (NATLIT _ x) = $1 in IntLit x NoInfo (srclocOf loc) }      | floatlit       { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo (srclocOf loc) }      | stringlit      { let L loc (STRINGLIT s) = $1 in                         StringLit (BS.unpack (T.encodeUtf8 s)) (srclocOf loc) }      | hole           { Hole NoInfo (srclocOf $1) }-     | '(' Exp ')' FieldAccesses-       { foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))-               (Parens $2 (srcspan $1 ($3:map snd $>)))-               $4 }-     | '(' Exp ')[' DimIndices ']'    { AppExp (Index (Parens $2 (srclocOf $1)) $4 (srcspan $1 $>)) NoInfo }-     | '(' Exp ',' Exps1 ')'          { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }-     | '('      ')'                   { TupLit [] (srcspan $1 $>) }-     | '[' Exps1 ']'                  { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }-     | '['       ']'                  { ArrayLit [] NoInfo (srcspan $1 $>) }+     | '(' Exp ')'            { Parens $2 (srcspan $1 $>) }+     | '(' Exp ',' Exps1 ')'  { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }+     | '('      ')'           { TupLit [] (srcspan $1 $>) }+     | '[' Exps1 ']'          { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }+     | '['       ']'          { ArrayLit [] NoInfo (srcspan $1 $>) } -     | QualVarSlice FieldAccesses-       { let ((v, vloc),slice,loc) = $1-         in foldl (\x (y, _) -> Project y x NoInfo (srcspan x (srclocOf x)))-                  (AppExp (Index (Var v NoInfo (srclocOf vloc)) slice (srcspan vloc loc)) NoInfo)-                  $2 }-     | QualName-       { Var (fst $1) NoInfo (srclocOf (snd $1)) }+     | id { let L loc (ID v)  = $1 in Var (QualName [] v) NoInfo (srclocOf loc) }++     | Atom '.' id+       { let L ploc (ID f) = $3+         in case $1 of+              Var (QualName qs v) NoInfo vloc ->+                Var (QualName (qs++[v]) f) NoInfo (srcspan vloc ploc)+              _ ->+                Project f $1 NoInfo (srcspan $1 ploc) }+     | Atom '.' natlit+       { let L ploc (NATLIT f _) = $3+         in Project f $1 NoInfo (srcspan $1 ploc) }+     | Atom '.' '(' Exp ')'+       {% case $1 of+            Var qn NoInfo vloc ->+              pure (QualParens (qn, srclocOf vloc) $4 (srcspan vloc $>))+            _ ->+              parseErrorAt $3 (Just "Can only locally open module names, not arbitrary expressions")+        }+     | Atom '...[' DimIndices ']'+       { AppExp (Index $1 $3 (srcspan $1 $>)) NoInfo }      | '{' Fields '}' { RecordLit $2 (srcspan $1 $>) }-     | 'qid.(' Exp ')'-       { let L loc (QUALPAREN qs name) = $1 in-         QualParens (QualName qs name, srclocOf loc) $2 (srcspan $1 $>) }       | SectionExp { $1 } @@ -654,12 +670,8 @@         : Exps1_ ',' Exp { (snd $1 : fst $1, $3) }         | Exp            { ([], $1) } -FieldAccess :: { (Name, Loc) }-             : '.' id { let L loc (ID f) = $2 in (f, loc) }-             | '.int' { let L loc (PROJ_INTFIELD x) = $1 in (x, loc) }- FieldAccesses :: { [(Name, Loc)] }-               : FieldAccess FieldAccesses { $1 : $2 }+               : '.' FieldId FieldAccesses { $2 : $3 }                |                           { [] }  FieldAccesses_ :: { [(Name, Loc)] }@@ -683,15 +695,15 @@      | let Pat '=' Exp LetBody        { AppExp (LetPat [] $2 $4 $5 (srcspan $1 $>)) NoInfo } -     | let id TypeParams FunParams1 maybeAscription(TypeExp) '=' Exp LetBody+     | let id LocalFunTypeParams FunParams1 maybeAscription(TypeExp) '=' Exp LetBody        { let L _ (ID name) = $2          in AppExp (LetFun name ($3, fst $4 : snd $4, $5, NoInfo, $7)                     $8 (srcspan $1 $>))                    NoInfo} -     | let VarSlice '=' Exp LetBody-       { let ((v,_),slice,loc) = $2; ident = Ident v NoInfo (srclocOf loc)-         in AppExp (LetWith ident ident slice $4 $5 (srcspan $1 $>)) NoInfo }+     | let id '...[' DimIndices ']' '=' Exp LetBody+       { let L vloc (ID v) = $2; ident = Ident v NoInfo (srclocOf vloc)+         in AppExp (LetWith ident ident $4 $7 $8 (srcspan $1 $>)) NoInfo }  LetBody :: { UncheckedExp }     : in Exp %prec letprec { $2 }@@ -744,8 +756,8 @@   | '(' BinOp ')'     { OpSection (fst $2) NoInfo (srcspan $1 $>) } -  | '(' FieldAccess FieldAccesses ')'-    { ProjectSection (map fst ($2:$3)) NoInfo (srcspan $1 $>) }+  | '(' '.' FieldAccesses_ ')'+    { ProjectSection (map fst $3) NoInfo (srcspan $1 $>) }    | '(' '.' '[' DimIndices ']' ')'     { IndexSection $4 NoInfo (srcspan $1 $>) }@@ -819,7 +831,7 @@  CFieldPats :: { [(Name, PatBase NoInfo Name)] }                 : CFieldPats1 { $1 }-                |                { [] }+                |             { [] }  CFieldPats1 :: { [(Name, PatBase NoInfo Name)] }                  : CFieldPat ',' CFieldPats1 { $1 : $3 }@@ -830,9 +842,11 @@                           in (PatLitInt (toInteger (ord x)), loc) }              | PrimLit  { (PatLitPrim (fst $1), snd $1) }              | intlit   { let L loc (INTLIT x) = $1 in (PatLitInt x, loc) }+             | natlit   { let L loc (NATLIT _ x) = $1 in (PatLitInt x, loc) }              | floatlit { let L loc (FLOATLIT x) = $1 in (PatLitFloat x, loc) }-             | '-' NumLit  { (PatLitPrim (primNegate (fst $2)), snd $2) }+             | '-' NumLit   { (PatLitPrim (primNegate (fst $2)), snd $2) }              | '-' intlit   { let L loc (INTLIT x) = $2 in (PatLitInt (negate x), loc) }+             | '-' natlit   { let L loc (NATLIT _ x) = $2 in (PatLitInt (negate x), loc) }              | '-' floatlit { let L loc (FLOATLIT x) = $2 in (PatLitFloat (negate x), loc) }  LoopForm :: { LoopFormBase NoInfo Name }@@ -843,18 +857,6 @@          | while Exp            { While $2 } -VarSlice :: { ((Name, Loc), UncheckedSlice, Loc) }-          : 'id[' DimIndices ']'-            { let L vloc (INDEXING v) = $1-              in ((v, backOneCol vloc), $2, locOf (srcspan $1 $>)) }--QualVarSlice :: { ((QualName Name, Loc), UncheckedSlice, Loc) }-              : VarSlice-                { let ((v, vloc), y, loc) = $1 in ((qualName v, vloc), y, loc) }-              | 'qid[' DimIndices ']'-                { let L vloc (QUALINDEXING qs v) = $1-                  in ((QualName qs v, backOneCol vloc), $2, locOf (srcspan $1 $>)) }- DimIndex :: { UncheckedDimIndex }          : Exp2                   { DimFix $1 }          | Exp2 ':' Exp2          { DimSlice (Just $1) (Just $3) Nothing }@@ -879,7 +881,7 @@  FieldId :: { (Name, Loc) }          : id     { let L loc (ID name) = $1 in (name, loc) }-         | intlit { let L loc (INTLIT n) = $1 in (nameFromString (show n), loc) }+         | natlit { let L loc (NATLIT x _) = $1 in (x, loc) }  Pat :: { PatBase NoInfo Name }      : '#[' AttrInfo ']' Pat  { PatAttr $2 $4 (srcspan $1 $>) }@@ -909,7 +911,7 @@  FieldPats :: { [(Name, PatBase NoInfo Name)] }                : FieldPats1 { $1 }-               |                { [] }+               |            { [] }  FieldPats1 :: { [(Name, PatBase NoInfo Name)] }                : FieldPat ',' FieldPats1 { $1 : $3 }@@ -922,6 +924,7 @@ AttrAtom :: { (AttrAtom Name, Loc) }           : id     { let L loc (ID s) =     $1 in (AtomName s, loc) }           | intlit { let L loc (INTLIT x) = $1 in (AtomInt x, loc) }+          | natlit { let L loc (NATLIT _ x) = $1 in (AtomInt x, loc) }  AttrInfo :: { AttrInfo Name }          : AttrAtom         { let (x,y) = $1 in AttrAtom x (srclocOf y) }

@@ -129,6 +129,7 @@ import Data.Fixed (mod') -- Weird location. import Data.Int (Int16, Int32, Int64, Int8) import Data.Map qualified as M+import Data.Text qualified as T import Data.Word (Word16, Word32, Word64, Word8) import Foreign.C.Types (CUShort (..)) import Futhark.Util (convFloat)@@ -1836,9 +1837,9 @@ convOp s from to = pretty s <> "_" <> pretty from <> "_" <> pretty to  -- | True if signed.  Only makes a difference for integer types.-prettySigned :: Bool -> PrimType -> String-prettySigned True (IntType it) = 'u' : drop 1 (prettyString it)-prettySigned _ t = prettyString t+prettySigned :: Bool -> PrimType -> T.Text+prettySigned True (IntType it) = T.cons 'u' (T.drop 1 (prettyText it))+prettySigned _ t = prettyText t  umul_hi8 :: Int8 -> Int8 -> Int8 umul_hi8 a b =

@@ -1320,7 +1320,7 @@     notAliasingParam params' names =       forM_ params' $ \p ->         let consumedNonunique p' =-              not (unique $ unInfo $ identType p') && (identName p' `S.member` names)+              not (consumableParamType $ unInfo $ identType p') && (identName p' `S.member` names)          in case find consumedNonunique $ S.toList $ patIdents p of               Just p' ->                 returnAliased (baseName $ identName p') loc@@ -1333,6 +1333,13 @@       concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2     returnAliasing expected got =       [(uniqueness expected, S.map aliasVar $ aliases got)]++    consumableParamType (Array _ u _ _) = u == Unique+    consumableParamType (Scalar Prim {}) = True+    consumableParamType (Scalar (TypeVar _ u _ _)) = u == Unique+    consumableParamType (Scalar (Record fs)) = all consumableParamType fs+    consumableParamType (Scalar (Sum fs)) = all (all consumableParamType) fs+    consumableParamType (Scalar Arrow {}) = False  checkBinding ::   ( Name,