futhark 0.18.1 → 0.18.2

raw patch · 58 files changed

+1853/−1578 lines, 58 filesdep ~versionsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: versions

API changes (from Hackage documentation)

Files

• docs/c-api.rst +13/−0
• docs/language-reference.rst +6/−0
• docs/man/futhark-dataset.rst +2/−0
• docs/usage.rst +12/−0
• futhark.cabal +3/−2
• rts/c/chaselev.h +0/−4
• rts/c/multicore_defs.h +0/−108
• rts/c/multicore_util.h +0/−103
• rts/c/opencl.h +1/−1
• rts/c/scheduler.h +878/−20
• rts/c/scheduler_common.h +0/−244
• rts/c/scheduler_tune.h +0/−127
• rts/c/subtask_queue.h +0/−247
• rts/c/util.h +9/−5
• src/Futhark/CLI/Check.hs +4/−2
• src/Futhark/CLI/REPL.hs +21/−19
• src/Futhark/CLI/Run.hs +7/−5
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +2/−0
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +4/−1
• src/Futhark/CodeGen/Backends/GenericC.hs +9/−6
• src/Futhark/CodeGen/Backends/GenericPython.hs +1/−1
• src/Futhark/CodeGen/Backends/MulticoreC.hs +44/−65
• src/Futhark/CodeGen/ImpGen.hs +2/−4
• src/Futhark/CodeGen/ImpGen/Kernels.hs +2/−5
• src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +3/−2
• src/Futhark/CodeGen/ImpGen/Multicore.hs +2/−2
• src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +2/−2
• src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +8/−6
• src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +1/−1
• src/Futhark/Compiler.hs +4/−3
• src/Futhark/Compiler/Program.hs +10/−4
• src/Futhark/Construct.hs +7/−3
• src/Futhark/Doc/Generator.hs +5/−5
• src/Futhark/Internalise.hs +14/−10
• src/Futhark/Internalise/Defunctionalise.hs +73/−5
• src/Futhark/Internalise/Monomorphise.hs +1/−1
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +2/−2
• src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +10/−0
• src/Futhark/Optimise/TileLoops.hs +308/−289
• src/Futhark/Pass/ExpandAllocations.hs +18/−8
• src/Futhark/Pass/ExtractKernels.hs +3/−1
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +1/−0
• src/Futhark/Pkg/Info.hs +2/−2
• src/Futhark/Pkg/Types.hs +4/−3
• src/Futhark/Util.hs +8/−2
• src/Language/Futhark/Interpreter.hs +6/−3
• src/Language/Futhark/Parser/Parser.y +6/−8
• src/Language/Futhark/Pretty.hs +5/−0
• src/Language/Futhark/Syntax.hs +9/−1
• src/Language/Futhark/Traversals.hs +3/−3
• src/Language/Futhark/TypeChecker.hs +23/−24
• src/Language/Futhark/TypeChecker/Match.hs +171/−0
• src/Language/Futhark/TypeChecker/Monad.hs +45/−19
• src/Language/Futhark/TypeChecker/Terms.hs +36/−180
• src/Language/Futhark/TypeChecker/Types.hs +1/−1
• src/Language/Futhark/Warnings.hs +24/−17
• src/futhark.hs +17/−1

@@ -344,6 +344,19 @@    During :c:func:`futhark_context_new`, read PTX code from the given    file instead of using the embedded program. +Multicore+---------++The following API functions are available when using the ``multicore``+backend.++.. c:function:: void context_config_set_num_threads(struct futhark_context_config *cfg, int n)++   The number of threads used to run parallel operations.  If set to a+   value less than ``1``, then the runtime system will use one thread+   per detected core.++ General guarantees ------------------ 

@@ -991,6 +991,12 @@ to a single type.  Further, unique types (see `In-place updates`_) must be explicitly annotated. +Type inference processes top-level declared in top-down order, and the+type of a top-level function must be completely inferred at its+definition site.  Specifically, if a top-level function uses+overloaded arithmetic operators, the resolution of those overloads+cannot be influenced by later uses of the function.+ .. _size-types:  Size Types

@@ -27,6 +27,8 @@ format.  The input format (whether textual or binary) is automatically detected. +Returns a nonzero exit code if it fails to write the full output.+ OPTIONS ======= 

@@ -264,6 +264,18 @@ OpenCL backend uses.  These then refer to grid size and thread block size, respectively. +Multicore options+~~~~~~~~~~~~~~~~~++The following options are supported by executables generated by the+``multicore`` backend:++  ``--num-threads=INT``++    The number of threads used to run parallel operations.  If set to+    a value less than ``1``, then the runtime system will use one+    thread per detected core.+ Compiling to Library -------------------- 

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           futhark-version:        0.18.1+version:        0.18.2 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -255,6 +255,7 @@       Language.Futhark.Syntax       Language.Futhark.Traversals       Language.Futhark.TypeChecker+      Language.Futhark.TypeChecker.Match       Language.Futhark.TypeChecker.Modules       Language.Futhark.TypeChecker.Monad       Language.Futhark.TypeChecker.Terms@@ -313,7 +314,7 @@     , utf8-string >=1     , vector >=0.12     , vector-binary-instances >=0.2.2.0-    , versions >=3.3.1+    , versions >=4.0.1     , zip-archive >=0.3.1.1     , zlib >=0.6.1.2   default-language: Haskell2010

@@ -1,8 +1,5 @@ // Start of chaselev.h -#ifndef _CHASELEV_H_-#define _CHASELEV_H_- /* Implementation of Chase-lev's concurrent lock-free deque    from ``Dynamic Circular Work-Stealing Deque`` (2005)    This implementation was ported from@@ -175,6 +172,5 @@   return nb_subtasks(q) < 1; } -#endif #endif // end of chaselev.h

@@ -1,108 +0,0 @@-// start of multicore_defs.h--#ifndef MULTICORE_DEFS-#define MULTICORE_DEFS--#include <signal.h>--/* #define MCPROFILE */--// Which queue implementation to use-#define MCJOBQUEUE-// NOTE! MCCHASELEV has been removed from multicore branch-// Switch to multicore_deque branch to use chase-lev deque-/* #define MCCHASELEV */---#if defined(_WIN32)-#include <windows.h>-#elif defined(__APPLE__)-#include <sys/sysctl.h>-// For getting cpu usage of threads-#include <mach/mach.h>-#include <sys/resource.h>-#elif defined(__linux__)-#include <sys/sysinfo.h>-#include <sys/resource.h>-#include <signal.h>-#endif---// Forward declarations-// Scheduler definitions-struct scheduler;-struct scheduler_info;-struct scheduler_subtask;-struct scheduler_task;---struct subtask_queue {-  int capacity;             // Size of the buffer.-  int first;                // Index of the start of the ring buffer.-  int num_used;             // Number of used elements in the buffer.-  struct subtask **buffer;--  pthread_mutex_t mutex;    // Mutex used for synchronisation.-  pthread_cond_t cond;      // Condition variable used for synchronisation.-  int dead;--#if defined(MCPROFILE)-  /* Profiling fields */-  uint64_t time_enqueue;-  uint64_t time_dequeue;-  uint64_t n_dequeues;-  uint64_t n_enqueues;-#endif-};----// Function definitions-typedef int (*segop_fn)(void* args, int64_t iterations, int tid, struct scheduler_info info);-typedef int (*parloop_fn)(void* args, int64_t start, int64_t end, int subtask_id, int tid);---/* A subtask that can be executed by a worker */-struct subtask {-  /* The parloop function */-  parloop_fn fn;-  /* Execution parameters */-  void* args;-  int64_t start, end;-  int id;--  /* Dynamic scheduling parameters */-  int chunkable;-  int64_t chunk_size;--  /* Shared variables across subtasks */-  volatile int *counter; // Counter for ongoing subtasks-  // Shared task timers and iterators-  int64_t *task_time;-  int64_t *task_iter;--  /* For debugging */-  const char *name;-};---struct worker {-  pthread_t thread;-  struct scheduler *scheduler;  /* Reference to the scheduler struct the worker belongs to*/-  struct subtask_queue q;-  int dead;-  int tid;                      /* Just a thread id */--  /* "thread local" time fields used for online algorithm */-  uint64_t timer;-  uint64_t total;-  int nested; /* How nested the current computation is */--  // Profiling fields-  int output_usage;            /* Whether to dump thread usage */-  uint64_t time_spent_working; /* Time spent in parloop functions */-};--#endif--// end of multicore_defs.h

@@ -1,103 +0,0 @@-// start of multicore_util.h--/* Multicore Utility functions */--#ifndef _MULTICORE_UTIL_H_-#define _MULTICORE_UTIL_H_--/* A wrapper for getting rusage on Linux and MacOS */-/* TODO maybe figure out this for windows */-static inline int getrusage_thread(struct rusage *rusage)-{-  int err = -1;-#if  defined(__APPLE__)-    thread_basic_info_data_t info = { 0 };-    mach_msg_type_number_t info_count = THREAD_BASIC_INFO_COUNT;-    kern_return_t kern_err;--    kern_err = thread_info(mach_thread_self(),-                           THREAD_BASIC_INFO,-                           (thread_info_t)&info,-                           &info_count);-    if (kern_err == KERN_SUCCESS) {-        memset(rusage, 0, sizeof(struct rusage));-        rusage->ru_utime.tv_sec = info.user_time.seconds;-        rusage->ru_utime.tv_usec = info.user_time.microseconds;-        rusage->ru_stime.tv_sec = info.system_time.seconds;-        rusage->ru_stime.tv_usec = info.system_time.microseconds;-        err = 0;-    } else {-        errno = EINVAL;-    }-#elif defined(__linux__)-    err = getrusage(RUSAGE_THREAD, rusage);-#endif-    return err;-}--/* returns the number of logical cores */-static int num_processors()-{-#if  defined(_WIN32)-/* https://docs.microsoft.com/en-us/windows/win32/api/sysinfoapi/ns-sysinfoapi-system_info */-    SYSTEM_INFO sysinfo;-    GetSystemInfo(&sysinfo);-    int ncores = sysinfo.dwNumberOfProcessors;-    fprintf(stderr, "Found %d cores on your Windows machine\n Is that correct?\n", ncores);-    return ncores;-#elif defined(__APPLE__)-    int ncores;-    size_t ncores_size = sizeof(ncores);-    CHECK_ERRNO(sysctlbyname("hw.logicalcpu", &ncores, &ncores_size, NULL, 0),-                "sysctlbyname (hw.logicalcpu)");-    return ncores;-#elif defined(__linux__)-  return get_nprocs();-#else-  fprintf(stderr, "operating system not recognised\n");-  return -1;-#endif-}--static inline void output_thread_usage(struct worker *worker)-{-  struct rusage usage;-  CHECK_ERRNO(getrusage_thread(&usage), "getrusage_thread");-  struct timeval user_cpu_time = usage.ru_utime;-  struct timeval sys_cpu_time = usage.ru_stime;-  fprintf(stderr, "tid: %2d - work time %10llu us - user time: %10llu us - sys: %10llu us\n",-          worker->tid,-          (long long unsigned)worker->time_spent_working / 1000,-          (long long unsigned)(user_cpu_time.tv_sec * 1000000 + user_cpu_time.tv_usec),-          (long long unsigned)(sys_cpu_time.tv_sec * 1000000 + sys_cpu_time.tv_usec));-}---static unsigned int g_seed;--// Used to seed the generator.-static inline void fast_srand(unsigned int seed) {-    g_seed = seed;-}--// Compute a pseudorandom integer.-// Output value in range [0, 32767]-static inline unsigned int fast_rand(void) {-    g_seed = (214013*g_seed+2531011);-    return (g_seed>>16)&0x7FFF;-}---int64_t min_int64(int64_t x, int64_t y)-{-  return x < y ? x : y;-}--int64_t max_int64(int64_t x, int64_t y)-{-  return x > y ? x : y;-}---#endif-// end of multicore_util.h

@@ -342,7 +342,7 @@ }  // Returns 0 on success.-static int list_devices(struct opencl_config *cfg) {+static int list_devices(void) {   struct opencl_device_option *devices;   size_t num_devices; 

@@ -1,8 +1,675 @@ // start of scheduler.h-#ifndef _SCHEDULER_H_-#define _SCHEDULER_H_ +// First, the API that the generated code will access.  In principle,+// we could then compile the scheduler separately and link an object+// file with the generated code.  In practice, we will embed all of+// this in the generated code. +// Scheduler handle.+struct scheduler;++// Initialise a scheduler (and start worker threads).+static int scheduler_init(struct scheduler *scheduler,+                          int num_workers,+                          double kappa);++// Shut down a scheduler (and destroy worker threads).+static int scheduler_destroy(struct scheduler *scheduler);++// Figure out the smallest amount of work that amortises task+// creation.+static int determine_kappa(double *kappa);++// How a segop should be scheduled.+enum scheduling {+  DYNAMIC,+  STATIC+};++// How a given task should be executed.  Filled out by the scheduler+// and passed to the segop function+struct scheduler_info {+  int64_t iter_pr_subtask;+  int64_t remainder;+  int nsubtasks;+  enum scheduling sched;+  int wake_up_threads;++  int64_t *task_time;+  int64_t *task_iter;+};++// A segop function.  This is what you hand the scheduler for+// execution.+typedef int (*segop_fn)(void* args,+                        int64_t iterations,+                        int tid,+                        struct scheduler_info info);++// A task for the scheduler to execute.+struct scheduler_segop {+  void *args;+  segop_fn top_level_fn;+  segop_fn nested_fn;+  int64_t iterations;+  enum scheduling sched;++  // Pointers to timer and iter associated with the task+  int64_t *task_time;+  int64_t *task_iter;++  // For debugging+  const char* name;+};++static inline int scheduler_prepare_task(struct scheduler *scheduler,+                                         struct scheduler_segop *task);++typedef int (*parloop_fn)(void* args,+                          int64_t start,+                          int64_t end,+                          int subtask_id,+                          int tid);++// A parallel parloop task.+struct scheduler_parloop {+  void* args;+  parloop_fn fn;+  int64_t iterations;+  struct scheduler_info info;++  // For debugging+  const char* name;+};++static inline int scheduler_execute_task(struct scheduler *scheduler,+                                         struct scheduler_parloop *task);++// Then the API implementation.++#include <signal.h>++#if defined(_WIN32)+#include <windows.h>+#elif defined(__APPLE__)+#include <sys/sysctl.h>+// For getting cpu usage of threads+#include <mach/mach.h>+#include <sys/resource.h>+#elif defined(__linux__)+#include <sys/sysinfo.h>+#include <sys/resource.h>+#include <signal.h>+#endif++/* Multicore Utility functions */++/* A wrapper for getting rusage on Linux and MacOS */+/* TODO maybe figure out this for windows */+static inline int getrusage_thread(struct rusage *rusage)+{+  int err = -1;+#if  defined(__APPLE__)+    thread_basic_info_data_t info = { 0 };+    mach_msg_type_number_t info_count = THREAD_BASIC_INFO_COUNT;+    kern_return_t kern_err;++    kern_err = thread_info(mach_thread_self(),+                           THREAD_BASIC_INFO,+                           (thread_info_t)&info,+                           &info_count);+    if (kern_err == KERN_SUCCESS) {+        memset(rusage, 0, sizeof(struct rusage));+        rusage->ru_utime.tv_sec = info.user_time.seconds;+        rusage->ru_utime.tv_usec = info.user_time.microseconds;+        rusage->ru_stime.tv_sec = info.system_time.seconds;+        rusage->ru_stime.tv_usec = info.system_time.microseconds;+        err = 0;+    } else {+        errno = EINVAL;+    }+#elif defined(__linux__)+    err = getrusage(RUSAGE_THREAD, rusage);+#endif+    return err;+}++/* returns the number of logical cores */+static int num_processors()+{+#if  defined(_WIN32)+/* https://docs.microsoft.com/en-us/windows/win32/api/sysinfoapi/ns-sysinfoapi-system_info */+    SYSTEM_INFO sysinfo;+    GetSystemInfo(&sysinfo);+    int ncores = sysinfo.dwNumberOfProcessors;+    fprintf(stderr, "Found %d cores on your Windows machine\n Is that correct?\n", ncores);+    return ncores;+#elif defined(__APPLE__)+    int ncores;+    size_t ncores_size = sizeof(ncores);+    CHECK_ERRNO(sysctlbyname("hw.logicalcpu", &ncores, &ncores_size, NULL, 0),+                "sysctlbyname (hw.logicalcpu)");+    return ncores;+#elif defined(__linux__)+  return get_nprocs();+#else+  fprintf(stderr, "operating system not recognised\n");+  return -1;+#endif+}++static unsigned int g_seed;++// Used to seed the generator.+static inline void fast_srand(unsigned int seed) {+    g_seed = seed;+}++// Compute a pseudorandom integer.+// Output value in range [0, 32767]+static inline unsigned int fast_rand(void) {+    g_seed = (214013*g_seed+2531011);+    return (g_seed>>16)&0x7FFF;+}++struct subtask_queue {+  int capacity;             // Size of the buffer.+  int first;                // Index of the start of the ring buffer.+  int num_used;             // Number of used elements in the buffer.+  struct subtask **buffer;++  pthread_mutex_t mutex;    // Mutex used for synchronisation.+  pthread_cond_t cond;      // Condition variable used for synchronisation.+  int dead;++#if defined(MCPROFILE)+  /* Profiling fields */+  uint64_t time_enqueue;+  uint64_t time_dequeue;+  uint64_t n_dequeues;+  uint64_t n_enqueues;+#endif+};++/* A subtask that can be executed by a worker */+struct subtask {+  /* The parloop function */+  parloop_fn fn;+  /* Execution parameters */+  void* args;+  int64_t start, end;+  int id;++  /* Dynamic scheduling parameters */+  int chunkable;+  int64_t chunk_size;++  /* Shared variables across subtasks */+  volatile int *counter; // Counter for ongoing subtasks+  // Shared task timers and iterators+  int64_t *task_time;+  int64_t *task_iter;++  /* For debugging */+  const char *name;+};+++struct worker {+  pthread_t thread;+  struct scheduler *scheduler;  /* Reference to the scheduler struct the worker belongs to*/+  struct subtask_queue q;+  int dead;+  int tid;                      /* Just a thread id */++  /* "thread local" time fields used for online algorithm */+  uint64_t timer;+  uint64_t total;+  int nested; /* How nested the current computation is */++  // Profiling fields+  int output_usage;            /* Whether to dump thread usage */+  uint64_t time_spent_working; /* Time spent in parloop functions */+};++static inline void output_worker_usage(struct worker *worker)+{+  struct rusage usage;+  CHECK_ERRNO(getrusage_thread(&usage), "getrusage_thread");+  struct timeval user_cpu_time = usage.ru_utime;+  struct timeval sys_cpu_time = usage.ru_stime;+  fprintf(stderr, "tid: %2d - work time %10llu us - user time: %10llu us - sys: %10llu us\n",+          worker->tid,+          (long long unsigned)worker->time_spent_working / 1000,+          (long long unsigned)(user_cpu_time.tv_sec * 1000000 + user_cpu_time.tv_usec),+          (long long unsigned)(sys_cpu_time.tv_sec * 1000000 + sys_cpu_time.tv_usec));+}++/* Doubles the size of the queue */+static inline int subtask_queue_grow_queue(struct subtask_queue *subtask_queue) {++  int new_capacity = 2 * subtask_queue->capacity;+#ifdef MCDEBUG+  fprintf(stderr, "Growing queue to %d\n", subtask_queue->capacity * 2);+#endif++  struct subtask **new_buffer = calloc(new_capacity, sizeof(struct subtask*));+  for (int i = 0; i < subtask_queue->num_used; i++) {+    new_buffer[i] = subtask_queue->buffer[(subtask_queue->first + i) % subtask_queue->capacity];+  }++  free(subtask_queue->buffer);+  subtask_queue->buffer = new_buffer;+  subtask_queue->capacity = new_capacity;+  subtask_queue->first = 0;++  return 0;+}++// Initialise a job queue with the given capacity.  The queue starts out+// empty.  Returns non-zero on error.+static inline int subtask_queue_init(struct subtask_queue *subtask_queue, int capacity)+{+  assert(subtask_queue != NULL);+  memset(subtask_queue, 0, sizeof(struct subtask_queue));++  subtask_queue->capacity = capacity;+  subtask_queue->buffer = calloc(capacity, sizeof(struct subtask*));+  if (subtask_queue->buffer == NULL) {+    return -1;+  }++  CHECK_ERRNO(pthread_mutex_init(&subtask_queue->mutex, NULL), "pthread_mutex_init");+  CHECK_ERRNO(pthread_cond_init(&subtask_queue->cond, NULL), "pthread_cond_init");++  return 0;+}++// Destroy the job queue.  Blocks until the queue is empty before it+// is destroyed.+static inline int subtask_queue_destroy(struct subtask_queue *subtask_queue)+{+  assert(subtask_queue != NULL);++  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");++  while (subtask_queue->num_used != 0) {+    CHECK_ERR(pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex), "pthread_cond_wait");+  }++  // Queue is now empty.  Let's kill it!+  subtask_queue->dead = 1;+  free(subtask_queue->buffer);+  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");++  return 0;+}++static inline void dump_queue(struct worker *worker)+{+  struct subtask_queue *subtask_queue = &worker->q;+  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");+  for (int i = 0; i < subtask_queue->num_used; i++) {+    struct subtask * subtask = subtask_queue->buffer[(subtask_queue->first + i) % subtask_queue->capacity];+    printf("queue tid %d with %d task %s\n", worker->tid, i, subtask->name);+  }+  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+}++// Push an element onto the end of the job queue.  Blocks if the+// subtask_queue is full (its size is equal to its capacity).  Returns+// non-zero on error.  It is an error to push a job onto a queue that+// has been destroyed.+static inline int subtask_queue_enqueue(struct worker *worker, struct subtask *subtask )+{+  assert(worker != NULL);+  struct subtask_queue *subtask_queue = &worker->q;++#ifdef MCPROFILE+  uint64_t start = get_wall_time();+#endif++  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");+  // Wait until there is room in the subtask_queue.+  while (subtask_queue->num_used == subtask_queue->capacity && !subtask_queue->dead) {+    if (subtask_queue->num_used == subtask_queue->capacity) {+      CHECK_ERR(subtask_queue_grow_queue(subtask_queue), "subtask_queue_grow_queue");+      continue;+    }+    CHECK_ERR(pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex), "pthread_cond_wait");+  }++  if (subtask_queue->dead) {+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+    return -1;+  }++  // If we made it past the loop, there is room in the subtask_queue.+  subtask_queue->buffer[(subtask_queue->first + subtask_queue->num_used) % subtask_queue->capacity] = subtask;+  subtask_queue->num_used++;++#ifdef MCPROFILE+  uint64_t end = get_wall_time();+  subtask_queue->time_enqueue += (end - start);+  subtask_queue->n_enqueues++;+#endif+  // Broadcast a reader (if any) that there is now an element.+  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");++  return 0;+}+++/* Like subtask_queue_dequeue, but with two differences:+   1) the subtask is stolen from the __front__ of the queue+   2) returns immediately if there is no subtasks queued,+      as we dont' want to block on another workers queue and+*/+static inline int subtask_queue_steal(struct worker *worker,+                                      struct subtask **subtask)+{+  struct subtask_queue *subtask_queue = &worker->q;+  assert(subtask_queue != NULL);++#ifdef MCPROFILE+  uint64_t start = get_wall_time();+#endif+  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");++  if (subtask_queue->num_used == 0) {+    CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+    return 1;+  }++  if (subtask_queue->dead) {+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+    return -1;+  }++  // Tasks gets stolen from the "front"+  struct subtask *cur_back = subtask_queue->buffer[subtask_queue->first];+  struct subtask *new_subtask = NULL;+  int remaining_iter = cur_back->end - cur_back->start;+  // If subtask is chunkable, we steal half of the iterations+  if (cur_back->chunkable && remaining_iter > 1) {+      int64_t half = remaining_iter / 2;+      new_subtask = malloc(sizeof(struct subtask));+      *new_subtask = *cur_back;+      new_subtask->start = cur_back->end - half;+      cur_back->end = new_subtask->start;+      __atomic_fetch_add(cur_back->counter, 1, __ATOMIC_RELAXED);+  } else {+    new_subtask = cur_back;+    subtask_queue->num_used--;+    subtask_queue->first = (subtask_queue->first + 1) % subtask_queue->capacity;+  }+  *subtask = new_subtask;++  if (*subtask == NULL) {+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthred_mutex_unlock");+    return 1;+  }++#ifdef MCPROFILE+  uint64_t end = get_wall_time();+  subtask_queue->time_dequeue += (end - start);+  subtask_queue->n_dequeues++;+#endif++  // Broadcast a writer (if any) that there is now room for more.+  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");++  return 0;+}+++// Pop an element from the back of the job queue.+// Optional argument can be provided to block or not+static inline int subtask_queue_dequeue(struct worker *worker,+                                        struct subtask **subtask, int blocking)+{+  assert(worker != NULL);+  struct subtask_queue *subtask_queue = &worker->q;++#ifdef MCPROFILE+  uint64_t start = get_wall_time();+#endif++  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");+  if (subtask_queue->num_used == 0 && !blocking) {+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+    return 1;+  }+  // Try to steal some work while the subtask_queue is empty+  while (subtask_queue->num_used == 0 && !subtask_queue->dead) {+    pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex);+  }++  if (subtask_queue->dead) {+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");+    return -1;+  }++  // dequeue pops from the back+  *subtask = subtask_queue->buffer[(subtask_queue->first + subtask_queue->num_used - 1) % subtask_queue->capacity];+  subtask_queue->num_used--;++  if (*subtask == NULL) {+    assert(!"got NULL ptr");+    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthred_mutex_unlock");+    return -1;+  }++#ifdef MCPROFILE+  uint64_t end = get_wall_time();+  subtask_queue->time_dequeue += (end - start);+  subtask_queue->n_dequeues++;+#endif++  // Broadcast a writer (if any) that there is now room for more.+  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");+  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");++  return 0;+}++static inline int subtask_queue_is_empty(struct subtask_queue *subtask_queue)+{+  return subtask_queue->num_used == 0;+}++/* Scheduler definitions */++struct scheduler {+  struct worker *workers;+  int num_threads;++  // If there is work to steal => active_work > 0+  volatile int active_work;++  // Only one error can be returned at the time now.  Maybe we can+  // provide a stack like structure for pushing errors onto if we wish+  // to backpropagte multiple errors+  volatile int error;++  // kappa time unit in nanoseconds+  double kappa;+};+++// Thread local variable worker struct+// Note that, accesses to tls variables are expensive+// Minimize direct references to this variable+__thread struct worker* worker_local = NULL;++static int64_t total_now(int64_t total, int64_t time) {+  return total + (get_wall_time_ns() - time);+}++static int random_other_worker(struct scheduler *scheduler, int my_id) {+  int my_num_workers = scheduler->num_threads;+  assert(my_num_workers != 1);+  int i = fast_rand() % (my_num_workers - 1);+  if (i >= my_id) {+    i++;+  }+#ifdef MCDEBUG+  assert(i >= 0);+  assert(i < my_num_workers);+  assert(i != my_id);+#endif++  return i;+}+++static inline int64_t compute_chunk_size(double kappa, struct subtask* subtask)+{+  double C = (double)*subtask->task_time / (double)*subtask->task_iter;+  if (C == 0.0F) C += DBL_EPSILON;+  return smax64((int64_t)(kappa / C), 1);+}++/* Takes a chunk from subtask and enqueues the remaining iterations onto the worker's queue */+/* A no-op if the subtask is not chunkable */+static inline struct subtask* chunk_subtask(struct worker* worker, struct subtask *subtask)+{+  if (subtask->chunkable) {+    // Do we have information from previous runs avaliable+    if (*subtask->task_iter > 0) {+      subtask->chunk_size = compute_chunk_size(worker->scheduler->kappa, subtask);+      assert(subtask->chunk_size > 0);+    }+    int64_t remaining_iter = subtask->end - subtask->start;+    assert(remaining_iter > 0);+    if (remaining_iter > subtask->chunk_size) {+      struct subtask *new_subtask = malloc(sizeof(struct subtask));+      *new_subtask = *subtask;+      // increment the subtask join counter to account for new subtask+      __atomic_fetch_add(subtask->counter, 1, __ATOMIC_RELAXED);+      // Update range parameters+      subtask->end = subtask->start + subtask->chunk_size;+      new_subtask->start = subtask->end;+      subtask_queue_enqueue(worker, new_subtask);+    }+  }+  return subtask;+}++static inline int run_subtask(struct worker* worker, struct subtask* subtask)+{+  assert(subtask != NULL);+  assert(worker != NULL);++  subtask = chunk_subtask(worker, subtask);+  worker->total = 0;+  worker->timer = get_wall_time_ns();+#if defined(MCPROFILE)+  int64_t start = worker->timer;+#endif+  worker->nested++;+  int err = subtask->fn(subtask->args, subtask->start, subtask->end,+                        subtask->chunkable ? worker->tid : subtask->id,+                        worker->tid);+  worker->nested--;+  // Some error occured during some other subtask+  // so we just clean-up and return+  if (worker->scheduler->error != 0) {+    // Even a failed task counts as finished.+    __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);+    free(subtask);+    return 0;+  }+  if (err != 0) {+    __atomic_store_n(&worker->scheduler->error, err, __ATOMIC_RELAXED);+  }+  // Total sequential time spent+  int64_t time_elapsed = total_now(worker->total, worker->timer);+#if defined(MCPROFILE)+  worker->time_spent_working += get_wall_time_ns() - start;+#endif+  int64_t iter = subtask->end - subtask->start;+  // report measurements+  // These updates should really be done using a single atomic CAS operation+  __atomic_fetch_add(subtask->task_time, time_elapsed, __ATOMIC_RELAXED);+  __atomic_fetch_add(subtask->task_iter, iter, __ATOMIC_RELAXED);+  // We need a fence here, since if the counter is decremented before either+  // of the two above are updated bad things can happen, e.g. if they are stack-allocated+  __atomic_thread_fence(__ATOMIC_SEQ_CST);+  __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);+  free(subtask);+  return 0;+}+++static inline int is_small(struct scheduler_segop *task, struct scheduler *scheduler, int *nsubtasks)+{+  int64_t time = *task->task_time;+  int64_t iter = *task->task_iter;++  if (task->sched == DYNAMIC || iter == 0) {+    *nsubtasks = scheduler->num_threads;+    return 0;+  }++  // Estimate the constant C+  double C = (double)time / (double)iter;+  double cur_task_iter = (double) task->iterations;++  // Returns true if the task is small i.e.+  // if the number of iterations times C is smaller+  // than the overhead of subtask creation+  if (C == 0.0F || C * cur_task_iter < scheduler->kappa) {+    *nsubtasks = 1;+    return 1;+  }++  // Else compute how many subtasks this tasks should create+  int64_t min_iter_pr_subtask = smax64(scheduler->kappa / C, 1);+  *nsubtasks = smin64(smax64(task->iterations / min_iter_pr_subtask, 1), scheduler->num_threads);++  return 0;+}++// TODO make this prettier+static inline struct subtask* create_subtask(parloop_fn fn,+                                             void* args,+                                             const char* name,+                                             volatile int* counter,+                                             int64_t *timer,+                                             int64_t *iter,+                                             int64_t start, int64_t end,+                                             int chunkable,+                                             int64_t chunk_size,+                                             int id)+{+  struct subtask* subtask = malloc(sizeof(struct subtask));+  if (subtask == NULL) {+    assert(!"malloc failed in create_subtask");+    return NULL;+  }+  subtask->fn         = fn;+  subtask->args       = args;++  subtask->counter    = counter;+  subtask->task_time  = timer;+  subtask->task_iter  = iter;++  subtask->start      = start;+  subtask->end        = end;+  subtask->id         = id;+  subtask->chunkable  = chunkable;+  subtask->chunk_size = chunk_size;++  subtask->name       = name;+  return subtask;+}+ static int dummy_counter = 0; static int64_t dummy_timer = 0; static int64_t dummy_iter = 0;@@ -59,8 +726,10 @@ static inline void *scheduler_worker(void* args) {   struct worker *worker = (struct worker*) args;+  struct scheduler *scheduler = worker->scheduler;   worker_local = worker;-  struct subtask * subtask = NULL;+  struct subtask *subtask = NULL;+   while(!is_finished(worker)) {     if (!subtask_queue_is_empty(&worker->q)) {       int retval = subtask_queue_dequeue(worker, &subtask, 0);@@ -69,8 +738,8 @@         CHECK_ERR(run_subtask(worker, subtask), "run_subtask");       } // else someone stole our work -    } else if (active_work) { /* steal */-      while (!is_finished(worker) && active_work) {+    } else if (scheduler->active_work) { /* steal */+      while (!is_finished(worker) && scheduler->active_work) {         if (steal_from_random_worker(worker)) {           break;         }@@ -85,10 +754,9 @@   }    assert(subtask_queue_is_empty(&worker->q));-  __atomic_fetch_sub(&num_workers, 1, __ATOMIC_RELAXED); #if defined(MCPROFILE)   if (worker->output_usage)-    output_thread_usage(worker);+    output_worker_usage(worker); #endif   return NULL; }@@ -99,7 +767,7 @@                                             int64_t *timer) { -  struct worker * worker = worker_local;+  struct worker *worker = worker_local;    struct scheduler_info info = task->info;   int64_t iter_pr_subtask = info.iter_pr_subtask;@@ -119,7 +787,7 @@     if (info.wake_up_threads || sched == DYNAMIC)-    __atomic_add_fetch(&active_work, nsubtasks, __ATOMIC_RELAXED);+    __atomic_add_fetch(&scheduler->active_work, nsubtasks, __ATOMIC_RELAXED);    int64_t start = 0;   int64_t end = iter_pr_subtask + (int64_t)(remainder != 0);@@ -131,13 +799,14 @@                                               chunkable, chunk_size,                                               subtask_id);     assert(subtask != NULL);-    if (worker->nested){-      CHECK_ERR(subtask_queue_enqueue(&scheduler->workers[worker->tid], subtask),-                "subtask_queue_enqueue");-    } else {-      CHECK_ERR(subtask_queue_enqueue(&scheduler->workers[subtask_id], subtask),-                "subtask_queue_enqueue");-    }+    // In most cases we will never have more subtasks than workers,+    // but there can be exceptions (e.g. the kappa tuning function).+    struct worker *subtask_worker =+      worker->nested+      ? &scheduler->workers[worker->tid]+      : &scheduler->workers[subtask_id % scheduler->num_threads];+    CHECK_ERR(subtask_queue_enqueue(subtask_worker, subtask),+              "subtask_queue_enqueue");     // Update range params     start = end;     end += iter_pr_subtask + ((subtask_id + 1) < remainder);@@ -168,12 +837,12 @@     if (info.wake_up_threads || sched == DYNAMIC) {-    __atomic_sub_fetch(&active_work, nsubtasks, __ATOMIC_RELAXED);+    __atomic_sub_fetch(&scheduler->active_work, nsubtasks, __ATOMIC_RELAXED);   }    // Write back timing results of all sequential work   (*timer) += task_timer;-  return scheduler_error;+  return scheduler->error; }  @@ -239,7 +908,7 @@    int nsubtasks;   // Decide if task should be scheduled sequentially-  if (is_small(task, scheduler->num_threads, &nsubtasks)) {+  if (is_small(task, scheduler, &nsubtasks)) {     info.iter_pr_subtask = task->iterations;     info.remainder = 0;     info.nsubtasks = nsubtasks;@@ -274,5 +943,194 @@   return task->top_level_fn(task->args, task->iterations, worker->tid, info); } -#endif+// Now some code for finding the proper value of kappa on a given+// machine (the smallest amount of work that amortises the cost of+// task creation).++struct tuning_struct {+  int32_t *free_tuning_res;+  int32_t *array;+};++// Reduction function over an integer array+static int tuning_loop(void *args, int64_t start, int64_t end,+                                     int flat_tid, int tid) {+  (void)flat_tid;+  (void)tid;++  int err = 0;+  struct tuning_struct *tuning_struct = (struct tuning_struct *) args;+  int32_t *array = tuning_struct->array;+  int32_t *tuning_res = tuning_struct->free_tuning_res;++  int32_t sum = 0;+  for (int i = start; i < end; i++) {+    int32_t y = array[i];+    sum = add32(sum, y);+  }+  *tuning_res = sum;+  return err;+}++// The main entry point for the tuning process.  Sets the provided+// variable ``kappa``.+static int determine_kappa(double *kappa) {+  int err = 0;++  int64_t iterations = 100000000;+  int64_t tuning_time = 0;+  int64_t tuning_iter = 0;++  int32_t *array = malloc(sizeof(int32_t) * iterations);+  for (int64_t i = 0; i < iterations; i++) {+    array[i] = fast_rand();+  }++  int64_t start_tuning = get_wall_time_ns();+  /* **************************** */+  /* Run sequential reduce first' */+  /* **************************** */+  int64_t tuning_sequentiual_start = get_wall_time_ns();+  struct tuning_struct tuning_struct;+  int32_t tuning_res;+  tuning_struct.free_tuning_res = &tuning_res;+  tuning_struct.array = array;++  err = tuning_loop(&tuning_struct, 0, iterations, 0, 0);+  int64_t tuning_sequentiual_end = get_wall_time_ns();+  int64_t sequential_elapsed = tuning_sequentiual_end - tuning_sequentiual_start;++  double C = (double)sequential_elapsed / (double)iterations;+  fprintf(stderr, " Time for sequential run is %lld - Found C %f\n", (long long)sequential_elapsed, C);++  /* ********************** */+  /* Now run tuning process */+  /* ********************** */+  // Setup a scheduler with a single worker+  struct scheduler scheduler;+  scheduler.num_threads = 1;+  scheduler.workers = malloc(sizeof(struct worker));+  worker_local = &scheduler.workers[0];+  worker_local->tid = 0;+  CHECK_ERR(subtask_queue_init(&scheduler.workers[0].q, 1024),+            "failed to init queue for worker %d\n", 0);++  // Start tuning for kappa+  double kappa_tune = 1000; // Initial kappa is 1 us+  double ratio;+  int64_t time_elapsed;+  while(1) {+    int64_t min_iter_pr_subtask = (int64_t) (kappa_tune / C) == 0 ? 1 : (kappa_tune / C);+    int nsubtasks = iterations / min_iter_pr_subtask;+    struct scheduler_info info;+    info.iter_pr_subtask = min_iter_pr_subtask;++    info.nsubtasks = iterations / min_iter_pr_subtask;+    info.remainder = iterations % min_iter_pr_subtask;+    info.task_time = &tuning_time;+    info.task_iter = &tuning_iter;+    info.sched = STATIC;++    struct scheduler_parloop parloop;+    parloop.name = "tuning_loop";+    parloop.fn = tuning_loop;+    parloop.args = &tuning_struct;+    parloop.iterations = iterations;+    parloop.info = info;++    int64_t tuning_chunked_start = get_wall_time_ns();+    int determine_kappa_err =+      scheduler_execute_task(&scheduler,+                             &parloop);+    assert(determine_kappa_err == 0);+    int64_t tuning_chunked_end = get_wall_time_ns();+    time_elapsed =  tuning_chunked_end - tuning_chunked_start;++    ratio = (double)time_elapsed / (double)sequential_elapsed;+    if (ratio < 1.055) {+      break;+    }+    kappa_tune += 100; // Increase by 100 ns at the time+    fprintf(stderr, "nsubtask %d - kappa %f - ratio %f\n", nsubtasks, kappa_tune, ratio);+  }++  int64_t end_tuning = get_wall_time_ns();+  fprintf(stderr, "tuning took %lld ns and found kappa %f - time %lld - ratio %f\n",+          (long long)end_tuning - start_tuning,+          kappa_tune,+          (long long)time_elapsed,+          ratio);+  *kappa = kappa_tune;++  // Clean-up+  CHECK_ERR(subtask_queue_destroy(&scheduler.workers[0].q), "failed to destroy queue");+  free(array);+  free(scheduler.workers);+  return err;+}++static int scheduler_init(struct scheduler *scheduler,+                          int num_workers,+                          double kappa) {+  assert(num_workers > 0);++  scheduler->kappa = kappa;+  scheduler->num_threads = num_workers;+  scheduler->active_work = 0;+  scheduler->error = 0;++  scheduler->workers = calloc(num_workers, sizeof(struct worker));++  const int queue_capacity = 1024;++  worker_local = &scheduler->workers[0];+  worker_local->tid = 0;+  worker_local->scheduler = scheduler;+  CHECK_ERR(subtask_queue_init(&worker_local->q, queue_capacity),+            "failed to init queue for worker %d\n", 0);++  for (int i = 1; i < num_workers; i++) {+    struct worker *cur_worker = &scheduler->workers[i];+    memset(cur_worker, 0, sizeof(struct worker));+    cur_worker->tid = i;+    cur_worker->output_usage = 0;+    cur_worker->scheduler = scheduler;+    CHECK_ERR(subtask_queue_init(&cur_worker->q, queue_capacity),+              "failed to init queue for worker %d\n", i);++    CHECK_ERR(pthread_create(&cur_worker->thread,+                             NULL,+                             &scheduler_worker,+                             cur_worker),+              "Failed to create worker %d\n", i);+  }++  return 0;+}++static int scheduler_destroy(struct scheduler *scheduler) {+  // First mark them all as dead.+  for (int i = 1; i < scheduler->num_threads; i++) {+    struct worker *cur_worker = &scheduler->workers[i];+    cur_worker->dead = 1;+  }++  // Then destroy their task queues (this will wake up the threads and+  // make them do their shutdown).+  for (int i = 1; i < scheduler->num_threads; i++) {+    struct worker *cur_worker = &scheduler->workers[i];+    subtask_queue_destroy(&cur_worker->q);+  }++  // Then actually wait for them to stop.+  for (int i = 1; i < scheduler->num_threads; i++) {+    struct worker *cur_worker = &scheduler->workers[i];+    CHECK_ERR(pthread_join(scheduler->workers[i].thread, NULL), "pthread_join");+  }++  free(scheduler->workers);++  return 0;+}+ // End of scheduler.h

@@ -1,244 +0,0 @@-// start of scheduler_common.h--#ifndef _SCHEDULER_COMMON_H_-#define _SCHEDULER_COMMON_H_--#include <float.h>--/* Scheduler definitions */-enum scheduling {-  DYNAMIC,-  STATIC-};--/* How a given task should be executed */-/* Filled out by the scheduler-   and passed to the segop function-*/-struct scheduler_info {-  int64_t iter_pr_subtask;-  int64_t remainder;-  int nsubtasks;-  enum scheduling sched;-  int wake_up_threads;--  int64_t *task_time;-  int64_t *task_iter;-};--struct scheduler {-  struct worker *workers;-  int num_threads;-};--/* A parallel parloop task  */-struct scheduler_parloop {-  const char* name;-  parloop_fn fn;-  void* args;-  int64_t iterations;-  struct scheduler_info info;-};---/* A task for the scheduler to execute */-struct scheduler_segop {-  void *args;-  segop_fn top_level_fn;-  segop_fn nested_fn;-  int64_t iterations;-  enum scheduling sched;--  // Pointers to timer and iter associated with the task-  int64_t *task_time;-  int64_t *task_iter;--  // For debugging-  const char* name;-};--// If there is work to steal => active_work > 0-static volatile int active_work = 0;-// Number of alive workers-static volatile sig_atomic_t num_workers;--// Thread local variable worker struct-// Note that, accesses to tls variables are expensive-// Minimize direct references to this variable-__thread struct worker* worker_local = NULL;--/* Only one error can be returned at the time now-   Maybe we can provide a stack like structure for pushing errors onto-   if we wish to backpropagte multiple errors */-static volatile sig_atomic_t scheduler_error = 0;--// kappa time unit in nanoseconds-static double kappa = 5.1f * 1000;--int64_t total_now(int64_t total, int64_t time) {-  return total + (get_wall_time_ns() - time);-}--int random_other_worker(struct scheduler *scheduler, int my_id) {-  (void)scheduler;-  int my_num_workers = __atomic_load_n(&num_workers, __ATOMIC_RELAXED);-  assert(my_num_workers != 1);-  int i = fast_rand() % (my_num_workers - 1);-  if (i >= my_id) {-    i++;-  }-#ifdef MCDEBUG-  assert(i >= 0);-  assert(i < my_num_workers);-  assert(i != my_id);-#endif--  return i;-}---static inline int64_t compute_chunk_size(struct subtask* subtask)-{-  double C = (double)*subtask->task_time / (double)*subtask->task_iter;-  if (C == 0.0F) C += DBL_EPSILON;-  return max_int64((int64_t)(kappa / C), 1);-}--/* Takes a chunk from subtask and enqueues the remaining iterations onto the worker's queue */-/* A no-op if the subtask is not chunkable */-static inline struct subtask* chunk_subtask(struct worker* worker, struct subtask *subtask)-{-  if (subtask->chunkable) {-    // Do we have information from previous runs avaliable-    if (*subtask->task_iter > 0) {-      subtask->chunk_size = compute_chunk_size(subtask);-      assert(subtask->chunk_size > 0);-    }-    int64_t remaining_iter = subtask->end - subtask->start;-    assert(remaining_iter > 0);-    if (remaining_iter > subtask->chunk_size) {-      struct subtask *new_subtask = malloc(sizeof(struct subtask));-      *new_subtask = *subtask;-      // increment the subtask join counter to account for new subtask-      __atomic_fetch_add(subtask->counter, 1, __ATOMIC_RELAXED);-      // Update range parameters-      subtask->end = subtask->start + subtask->chunk_size;-      new_subtask->start = subtask->end;-      subtask_queue_enqueue(worker, new_subtask);-    }-  }-  return subtask;-}--static inline int run_subtask(struct worker* worker, struct subtask* subtask)-{-  assert(subtask != NULL);-  assert(worker != NULL);--  subtask = chunk_subtask(worker, subtask);-  worker->total = 0;-  worker->timer = get_wall_time_ns();-#if defined(MCPROFILE)-  int64_t start = worker->timer;-#endif-  worker->nested++;-  int err = subtask->fn(subtask->args, subtask->start, subtask->end,-                        subtask->chunkable ? worker->tid : subtask->id,-                        worker->tid);-  worker->nested--;-  // Some error occured during some other subtask-  // so we just clean-up and return-  if (scheduler_error != 0) {-    // Even a failed task counts as finished.-    __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);-    free(subtask);-    return 0;-  }-  if (err != 0) {-    __atomic_store_n(&scheduler_error, err, __ATOMIC_RELAXED);-  }-  // Total sequential time spent-  int64_t time_elapsed = total_now(worker->total, worker->timer);-#if defined(MCPROFILE)-  worker->time_spent_working += get_wall_time_ns() - start;-#endif-  int64_t iter = subtask->end - subtask->start;-  // report measurements-  // These updates should really be done using a single atomic CAS operation-  __atomic_fetch_add(subtask->task_time, time_elapsed, __ATOMIC_RELAXED);-  __atomic_fetch_add(subtask->task_iter, iter, __ATOMIC_RELAXED);-  // We need a fence here, since if the counter is decremented before either-  // of the two above are updated bad things can happen, e.g. if they are stack-allocated-  __atomic_thread_fence(__ATOMIC_SEQ_CST);-  __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);-  free(subtask);-  return 0;-}---static inline int is_small(struct scheduler_segop *task, int nthreads, int *nsubtasks)-{-  int64_t time = *task->task_time;-  int64_t iter = *task->task_iter;--  if (task->sched == DYNAMIC || iter == 0) {-    *nsubtasks = nthreads;-    return 0;-  }--  // Estimate the constant C-  double C = (double)time / (double)iter;-  double cur_task_iter = (double) task->iterations;--  // Returns true if the task is small i.e.-  // if the number of iterations times C is smaller-  // than the overhead of subtask creation-  if (C == 0.0F || C * cur_task_iter < kappa) {-    *nsubtasks = 1;-    return 1;-  }--  // Else compute how many subtasks this tasks should create-  int64_t min_iter_pr_subtask = max_int64((int64_t)(kappa / C), 1);-  *nsubtasks = (int)min_int64(max_int64(task->iterations / min_iter_pr_subtask, 1), nthreads);--  return 0;-}--// TODO make this prettier-static inline struct subtask* create_subtask(parloop_fn fn,-                                             void* args,-                                             const char* name,-                                             volatile int* counter,-                                             int64_t *timer,-                                             int64_t *iter,-                                             int64_t start, int64_t end,-                                             int chunkable,-                                             int64_t chunk_size,-                                             int id)-{-  struct subtask* subtask = malloc(sizeof(struct subtask));-  if (subtask == NULL) {-    assert(!"malloc failed in create_subtask");-    return NULL;-  }-  subtask->fn         = fn;-  subtask->args       = args;--  subtask->counter    = counter;-  subtask->task_time  = timer;-  subtask->task_iter  = iter;--  subtask->start      = start;-  subtask->end        = end;-  subtask->id         = id;-  subtask->chunkable  = chunkable;-  subtask->chunk_size = chunk_size;--  subtask->name       = name;-  return subtask;-}---#endif-// end of scheduler_common.h

@@ -1,127 +0,0 @@-/* The self-tuning program to estimate $\kappa$ */--struct futhark_mc_segred_stage_1_struct {-  struct futhark_context *ctx;-  int32_t *free_tuning_res;-  int32_t *array;-};--/* Reduction function over an integer array */-int futhark_mc_tuning_segred_stage_1(void *args, int64_t start, int64_t end,-                                     int flat_tid, int tid) {-  (void)flat_tid;-  (void)tid;--  int err = 0;-  struct futhark_mc_segred_stage_1_struct *futhark_mc_segred_stage_1_struct = (struct futhark_mc_segred_stage_1_struct *) args;-  struct futhark_context *ctx = futhark_mc_segred_stage_1_struct->ctx;-  int32_t *array = futhark_mc_segred_stage_1_struct->array;-  int32_t *tuning_res = futhark_mc_segred_stage_1_struct->free_tuning_res;--  int32_t sum = 0;-  for (int i = start; i < end; i++) {-    int32_t y = array[i];-    sum = add32(sum, y);-  }-  *tuning_res = sum;-  return err;-}--/* The main entry point for the tuning process */-/* Sets the global variable ``kappa`` */-int futhark_segred_tuning_program(struct futhark_context *ctx)-{-  int err = 0;--  int64_t iterations = 100000000;-  int64_t tuning_time = 0;-  int64_t tuning_iter = 0;--  int32_t *array = malloc(sizeof(int32_t) * iterations);-  for (int64_t i = 0; i < iterations; i++) {-    array[i] = fast_rand();-  }--  int64_t start_tuning = get_wall_time_ns();-  /* **************************** */-  /* Run sequential reduce first' */-  /* **************************** */-  int64_t tuning_sequentiual_start = get_wall_time_ns();-  struct futhark_mc_segred_stage_1_struct futhark_mc_segred_stage_1_struct;-  int32_t tuning_res;-  futhark_mc_segred_stage_1_struct.ctx = ctx;-  futhark_mc_segred_stage_1_struct.free_tuning_res = &tuning_res;-  futhark_mc_segred_stage_1_struct.array = array;--  err = futhark_mc_tuning_segred_stage_1(&futhark_mc_segred_stage_1_struct, 0, iterations, 0, 0);-  int64_t tuning_sequentiual_end = get_wall_time_ns();-  int64_t sequential_elapsed = tuning_sequentiual_end - tuning_sequentiual_start;--  double C = (double)sequential_elapsed / (double)iterations;-  fprintf(stderr, " Time for sequential run is %lld - Found C %f\n", (long long)sequential_elapsed, C);--  /* ********************** */-  /* Now run tuning process */-  /* ********************** */-  // Setup a scheduler with a single worker-  int num_threads = ctx->scheduler.num_threads;-  ctx->scheduler.num_threads = 1;-  ctx->scheduler.workers = malloc(sizeof(struct worker));-  worker_local = &ctx->scheduler.workers[0];-  worker_local->tid = 0;-  CHECK_ERR(subtask_queue_init(&ctx->scheduler.workers[0].q, 1024), "failed to init queue for worker %d\n", 0);--  // Start tuning for kappa-  double kappa_tune = 1000; // Initial kappa is 1 us-  double ratio;-  int64_t time_elapsed;-  while(1) {-    int64_t min_iter_pr_subtask = (int64_t) (kappa_tune / C) == 0 ? 1 : (kappa_tune / C);-    int nsubtasks = iterations / min_iter_pr_subtask;-    struct scheduler_info info;-    info.iter_pr_subtask = min_iter_pr_subtask;--    info.nsubtasks = iterations / min_iter_pr_subtask;-    info.remainder = iterations % min_iter_pr_subtask;-    info.task_time = &tuning_time;-    info.task_iter = &tuning_iter;-    info.sched = STATIC;--    struct scheduler_parloop futhark_segred_tuning_scheduler_parloop;-    futhark_segred_tuning_scheduler_parloop.name = "futhark_mc_tuning_segred_stage_1";-    futhark_segred_tuning_scheduler_parloop.fn = futhark_mc_tuning_segred_stage_1;-    futhark_segred_tuning_scheduler_parloop.args = &futhark_mc_segred_stage_1_struct;-    futhark_segred_tuning_scheduler_parloop.iterations = iterations;-    futhark_segred_tuning_scheduler_parloop.info = info;--    int64_t tuning_chunked_start = get_wall_time_ns();-    int futhark_segred_tuning_program_err =-      scheduler_execute_task(&ctx->scheduler,-                             &futhark_segred_tuning_scheduler_parloop);-    assert(futhark_segred_tuning_program_err == 0);-    int64_t tuning_chunked_end = get_wall_time_ns();-    time_elapsed =  tuning_chunked_end - tuning_chunked_start;--    ratio = (double)time_elapsed / (double)sequential_elapsed;-    if (ratio < 1.055) {-      break;-    }-    kappa_tune += 100; // Increase by 100 ns at the time-    fprintf(stderr, "nsubtask %d - kappa %f - ratio %f\n", nsubtasks, kappa_tune, ratio);-  }--  int64_t end_tuning = get_wall_time_ns();-  fprintf(stderr, "tuning took %lld ns and found kappa %f - time %lld - ratio %f\n",-          (long long)end_tuning - start_tuning,-          kappa_tune,-          (long long)time_elapsed,-          ratio);-  kappa = kappa_tune;--  // Clean-up-  CHECK_ERR(subtask_queue_destroy(&ctx->scheduler.workers[0].q), "failed to destroy queue");-  free(array);-  free(ctx->scheduler.workers);-  ctx->scheduler.num_threads = num_threads;-  return err;-}

@@ -1,247 +0,0 @@-// start of subtask_queue.h--#ifndef SUBTASK_QUEUE_H-#define SUBTASK_QUEUE_H--/* Doubles the size of the queue */-static inline int subtask_queue_grow_queue(struct subtask_queue *subtask_queue) {--  int new_capacity = 2 * subtask_queue->capacity;-#ifdef MCDEBUG-  fprintf(stderr, "Growing queue to %d\n", subtask_queue->capacity * 2);-#endif--  struct subtask **new_buffer = calloc(new_capacity, sizeof(struct subtask*));-  for (int i = 0; i < subtask_queue->num_used; i++) {-    new_buffer[i] = subtask_queue->buffer[(subtask_queue->first + i) % subtask_queue->capacity];-  }--  free(subtask_queue->buffer);-  subtask_queue->buffer = new_buffer;-  subtask_queue->capacity = new_capacity;-  subtask_queue->first = 0;--  return 0;-}--// Initialise a job queue with the given capacity.  The queue starts out-// empty.  Returns non-zero on error.-static inline int subtask_queue_init(struct subtask_queue *subtask_queue, int capacity)-{-  assert(subtask_queue != NULL);-  memset(subtask_queue, 0, sizeof(struct subtask_queue));--  subtask_queue->capacity = capacity;-  subtask_queue->buffer = calloc(capacity, sizeof(struct subtask*));-  if (subtask_queue->buffer == NULL) {-    return -1;-  }--  CHECK_ERRNO(pthread_mutex_init(&subtask_queue->mutex, NULL), "pthread_mutex_init");-  CHECK_ERRNO(pthread_cond_init(&subtask_queue->cond, NULL), "pthread_cond_init");--  return 0;-}--// Destroy the job queue.  Blocks until the queue is empty before it-// is destroyed.-static inline int subtask_queue_destroy(struct subtask_queue *subtask_queue)-{-  assert(subtask_queue != NULL);--  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");--  while (subtask_queue->num_used != 0) {-    CHECK_ERR(pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex), "pthread_cond_wait");-  }--  // Queue is now empty.  Let's kill it!-  subtask_queue->dead = 1;-  free(subtask_queue->buffer);-  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");--  return 0;-}--static inline void dump_queue(struct worker *worker)-{-  struct subtask_queue *subtask_queue = &worker->q;-  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");-  for (int i = 0; i < subtask_queue->num_used; i++) {-    struct subtask * subtask = subtask_queue->buffer[(subtask_queue->first + i) % subtask_queue->capacity];-    printf("queue tid %d with %d task %s\n", worker->tid, i, subtask->name);-  }-  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-}--// Push an element onto the end of the job queue.  Blocks if the-// subtask_queue is full (its size is equal to its capacity).  Returns-// non-zero on error.  It is an error to push a job onto a queue that-// has been destroyed.-static inline int subtask_queue_enqueue(struct worker *worker, struct subtask *subtask )-{-  assert(worker != NULL);-  struct subtask_queue *subtask_queue = &worker->q;--#ifdef MCPROFILE-  uint64_t start = get_wall_time();-#endif--  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");-  // Wait until there is room in the subtask_queue.-  while (subtask_queue->num_used == subtask_queue->capacity && !subtask_queue->dead) {-    if (subtask_queue->num_used == subtask_queue->capacity) {-      CHECK_ERR(subtask_queue_grow_queue(subtask_queue), "subtask_queue_grow_queue");-      continue;-    }-    CHECK_ERR(pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex), "pthread_cond_wait");-  }--  if (subtask_queue->dead) {-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-    return -1;-  }--  // If we made it past the loop, there is room in the subtask_queue.-  subtask_queue->buffer[(subtask_queue->first + subtask_queue->num_used) % subtask_queue->capacity] = subtask;-  subtask_queue->num_used++;--#ifdef MCPROFILE-  uint64_t end = get_wall_time();-  subtask_queue->time_enqueue += (end - start);-  subtask_queue->n_enqueues++;-#endif-  // Broadcast a reader (if any) that there is now an element.-  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");--  return 0;-}---/* Like subtask_queue_dequeue, but with two differences:-   1) the subtask is stolen from the __front__ of the queue-   2) returns immediately if there is no subtasks queued,-      as we dont' want to block on another workers queue and-*/-static inline int subtask_queue_steal(struct worker *worker,-                                      struct subtask **subtask)-{-  struct subtask_queue *subtask_queue = &worker->q;-  assert(subtask_queue != NULL);--#ifdef MCPROFILE-  uint64_t start = get_wall_time();-#endif-  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");--  if (subtask_queue->num_used == 0) {-    CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-    return 1;-  }--  if (subtask_queue->dead) {-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-    return -1;-  }--  // Tasks gets stolen from the "front"-  struct subtask *cur_back = subtask_queue->buffer[subtask_queue->first];-  struct subtask *new_subtask = NULL;-  int remaining_iter = cur_back->end - cur_back->start;-  // If subtask is chunkable, we steal half of the iterations-  if (cur_back->chunkable && remaining_iter > 1) {-      int64_t half = remaining_iter / 2;-      new_subtask = malloc(sizeof(struct subtask));-      *new_subtask = *cur_back;-      new_subtask->start = cur_back->end - half;-      cur_back->end = new_subtask->start;-      __atomic_fetch_add(cur_back->counter, 1, __ATOMIC_RELAXED);-  } else {-    new_subtask = cur_back;-    subtask_queue->num_used--;-    subtask_queue->first = (subtask_queue->first + 1) % subtask_queue->capacity;-  }-  *subtask = new_subtask;--  if (*subtask == NULL) {-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthred_mutex_unlock");-    return 1;-  }--#ifdef MCPROFILE-  uint64_t end = get_wall_time();-  subtask_queue->time_dequeue += (end - start);-  subtask_queue->n_dequeues++;-#endif--  // Broadcast a writer (if any) that there is now room for more.-  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");--  return 0;-}---// Pop an element from the back of the job queue.-// Optional argument can be provided to block or not-static inline int subtask_queue_dequeue(struct worker *worker,-                                        struct subtask **subtask, int blocking)-{-  assert(worker != NULL);-  struct subtask_queue *subtask_queue = &worker->q;--#ifdef MCPROFILE-  uint64_t start = get_wall_time();-#endif--  CHECK_ERR(pthread_mutex_lock(&subtask_queue->mutex), "pthread_mutex_lock");-  if (subtask_queue->num_used == 0 && !blocking) {-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-    return 1;-  }-  // Try to steal some work while the subtask_queue is empty-  while (subtask_queue->num_used == 0 && !subtask_queue->dead) {-    pthread_cond_wait(&subtask_queue->cond, &subtask_queue->mutex);-  }--  if (subtask_queue->dead) {-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");-    return -1;-  }--  // dequeue pops from the back-  *subtask = subtask_queue->buffer[(subtask_queue->first + subtask_queue->num_used - 1) % subtask_queue->capacity];-  subtask_queue->num_used--;--  if (*subtask == NULL) {-    assert(!"got NULL ptr");-    CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthred_mutex_unlock");-    return -1;-  }--#ifdef MCPROFILE-  uint64_t end = get_wall_time();-  subtask_queue->time_dequeue += (end - start);-  subtask_queue->n_dequeues++;-#endif--  // Broadcast a writer (if any) that there is now room for more.-  CHECK_ERR(pthread_cond_broadcast(&subtask_queue->cond), "pthread_cond_broadcast");-  CHECK_ERR(pthread_mutex_unlock(&subtask_queue->mutex), "pthread_mutex_unlock");--  return 0;-}--static inline int subtask_queue_is_empty(struct subtask_queue *subtask_queue)-{-  return subtask_queue->num_used == 0;-}---#endif--// End of subtask_queue.h

@@ -30,15 +30,19 @@   static inline void check_err(int errval, int sets_errno, const char *fun, int line,-                            const char *msg, ...)-{+                            const char *msg, ...) {   if (errval) {     char str[256];     char errnum[10];-    sprintf(errnum, "%d", errval);-    sprintf(str, "ERROR: %s in %s() at line %d with error code %s\n", msg, fun, line,++    va_list vl;+    va_start(vl, msg);++    fprintf(stderr, "ERROR: ");+    vfprintf(stderr, msg, vl);+    fprintf(stderr, " in %s() at line %d with error code %s\n",+            fun, line,             sets_errno ? strerror(errno) : errnum);-    fprintf(stderr, "%s", str);     exit(errval);   } }

@@ -5,6 +5,8 @@ import Control.Monad.IO.Class import Futhark.Compiler import Futhark.Util.Options+import Futhark.Util.Pretty (pretty)+import Language.Futhark.Warnings import System.Console.GetOpt import System.IO @@ -28,6 +30,6 @@   case args of     [file] -> Just $ do       (warnings, _, _) <- readProgramOrDie file-      when (checkWarn cfg) $-        liftIO $ hPutStr stderr $ show warnings+      when (checkWarn cfg && anyWarnings warnings) $+        liftIO $ hPutStrLn stderr $ pretty warnings     _ -> Nothing

@@ -160,12 +160,13 @@       -- Then make the prelude available in the type checker.       (tenv, d, src') <-         badOnLeft pretty $-          T.checkDec-            imports-            src-            T.initialEnv-            (T.mkInitialImport ".")-            $ mkOpen "/prelude/prelude"+          snd $+            T.checkDec+              imports+              src+              T.initialEnv+              (T.mkInitialImport ".")+              $ mkOpen "/prelude/prelude"       -- Then in the interpreter.       ienv' <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv d)       return (imports, src', tenv, ienv')@@ -177,7 +178,7 @@                 `catch` \(err :: IOException) ->                   return (externalErrorS (show err))             )-      liftIO $ print ws+      liftIO $ putStrLn $ pretty ws        let imp = T.mkInitialImport "."       ienv1 <-@@ -185,12 +186,14 @@           map (fmap fileProg) imports       (tenv1, d1, src') <-         badOnLeft pretty $-          T.checkDec imports src T.initialEnv imp $-            mkOpen "/prelude/prelude"+          snd $+            T.checkDec imports src T.initialEnv imp $+              mkOpen "/prelude/prelude"       (tenv2, d2, src'') <-         badOnLeft pretty $-          T.checkDec imports src' tenv1 imp $-            mkOpen $ toPOSIX $ dropExtension file+          snd $+            T.checkDec imports src' tenv1 imp $+              mkOpen $ toPOSIX $ dropExtension file       ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)       ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)       return (imports, src'', tenv2, ienv3)@@ -290,8 +293,8 @@     Left e -> liftIO $ print e     Right (_, imports', src') ->       case T.checkDec imports' src' tenv cur_import d of-        Left e -> liftIO $ putStrLn $ pretty e-        Right (tenv', d', src'') -> do+        (_, Left e) -> liftIO $ putStrLn $ pretty e+        (_, Right (tenv', d', src'')) -> do           let new_imports = filter ((`notElem` map fst imports) . fst) imports'           int_r <- runInterpreter $ do             let onImport ienv' (s, imp) =@@ -310,10 +313,9 @@ onExp :: UncheckedExp -> FutharkiM () onExp e = do   (imports, src, tenv, ienv) <- getIt-  case either (Left . pretty) Right $-    T.checkExp imports src tenv e of-    Left err -> liftIO $ putStrLn err-    Right (tparams, e')+  case T.checkExp imports src tenv e of+    (_, Left err) -> liftIO $ putStrLn $ pretty err+    (_, Right (tparams, e'))       | null tparams -> do         r <- runInterpreter $ I.interpretExp ienv e'         case r of@@ -416,7 +418,7 @@ genTypeCommand ::   Show err =>   (String -> T.Text -> Either err a) ->-  (Imports -> VNameSource -> T.Env -> a -> Either T.TypeError b) ->+  (Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->   (b -> String) ->   Command genTypeCommand f g h e = do@@ -427,7 +429,7 @@       imports <- gets futharkiImports       src <- gets futharkiNameSource       (tenv, _) <- gets futharkiEnv-      case g imports src tenv e' of+      case snd $ g imports src tenv e' of         Left err -> liftIO $ putStrLn $ pretty err         Right x -> liftIO $ putStrLn $ h x 

@@ -123,7 +123,7 @@               return (externalErrorS (show err))         )   when (interpreterPrintWarnings cfg) $-    liftIO $ hPutStr stderr $ show ws+    liftIO $ hPutStr stderr $ pretty ws    let imp = T.mkInitialImport "."   ienv1 <-@@ -131,12 +131,14 @@       map (fmap fileProg) imports   (tenv1, d1, src') <-     badOnLeft pretty $-      T.checkDec imports src T.initialEnv imp $-        mkOpen "/prelude/prelude"+      snd $+        T.checkDec imports src T.initialEnv imp $+          mkOpen "/prelude/prelude"   (tenv2, d2, _) <-     badOnLeft pretty $-      T.checkDec imports src' tenv1 imp $-        mkOpen $ toPOSIX $ dropExtension file+      snd $+        T.checkDec imports src' tenv1 imp $+          mkOpen $ toPOSIX $ dropExtension file   ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)   ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)   return (tenv2, ienv3)

@@ -461,7 +461,9 @@   GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->     ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],       [C.cedecl|int $id:s(struct $id:ctx* ctx) {+                         lock_lock(&ctx->lock);                          CUDA_SUCCEED(cuda_free_all(&ctx->cuda));+                         lock_unlock(&ctx->lock);                          return 0;                        }|]     )

@@ -211,7 +211,8 @@   GC.publicDef_ "context_config_list_devices" GC.InitDecl $ \s ->     ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|],       [C.cedecl|void $id:s(struct $id:cfg* cfg) {-                         list_devices(&cfg->opencl);+                         (void)cfg;+                         list_devices();                        }|]     ) @@ -492,7 +493,9 @@   GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->     ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],       [C.cedecl|int $id:s(struct $id:ctx* ctx) {+                         lock_lock(&ctx->lock);                          ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(&ctx->opencl));+                         lock_unlock(&ctx->lock);                          return ctx->error != NULL;                        }|]     )

@@ -1053,11 +1053,13 @@     (OpaqueDecl desc)     [C.cedecl|int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj);|] +  ops <- asks envOperations+   return     [C.cunit|           int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj) {             int ret = 0, tmp;-            $items:free_body+            $items:(criticalSection ops free_body)             free(obj);             return ret;           }@@ -1652,6 +1654,7 @@ $esc:("#include <stdint.h>") $esc:("#include <stddef.h>") $esc:("#include <stdbool.h>")+$esc:("#include <float.h>") $esc:(header_extra)  $esc:("\n// Initialisation\n")@@ -1912,8 +1915,8 @@         | null const_fields = [[C.csdecl|int dummy;|]]         | otherwise = const_fields   contextField "constants" [C.cty|struct { $sdecls:const_fields' }|] Nothing-  earlyDecl [C.cedecl|int init_constants($ty:ctx_ty*);|]-  earlyDecl [C.cedecl|int free_constants($ty:ctx_ty*);|]+  earlyDecl [C.cedecl|static int init_constants($ty:ctx_ty*);|]+  earlyDecl [C.cedecl|static int free_constants($ty:ctx_ty*);|]    -- We locally define macros for the constants, so that when we   -- generate assignments to local variables, we actually assign into@@ -1924,7 +1927,7 @@     mapM_ resetMemConst ps     compileCode init_consts   libDecl-    [C.cedecl|int init_constants($ty:ctx_ty *ctx) {+    [C.cedecl|static int init_constants($ty:ctx_ty *ctx) {       (void)ctx;       int err = 0;       $items:defs@@ -1936,7 +1939,7 @@    free_consts <- collect $ mapM_ freeConst ps   libDecl-    [C.cedecl|int free_constants($ty:ctx_ty *ctx) {+    [C.cedecl|static int free_constants($ty:ctx_ty *ctx) {       (void)ctx;       $items:free_consts       return 0;@@ -2129,7 +2132,7 @@       iexp' <- compileExp $ untyped iexp       return [C.cexp|$id:src[$exp:iexp']|]     compileLeaf (SizeOf t) =-      return [C.cexp|(typename int32_t)sizeof($ty:t')|]+      return [C.cexp|(typename int64_t)sizeof($ty:t')|]       where         t' = primTypeToCType t 

@@ -475,7 +475,7 @@   let shape_name = Field arr_name "shape"       src = Index shape_name $ IdxExp $ Integer $ toInteger i   var' <- compileVar var-  stm $ Assign var' $ simpleCall "np.int32" [src]+  stm $ Assign var' $ simpleCall "np.int64" [src]  entryPointOutput :: Imp.ExternalValue -> CompilerM op s PyExp entryPointOutput (Imp.OpaqueValue desc vs) =

@@ -43,29 +43,15 @@     <=< ImpGen.compileProg   where     generateContext = do-      let multicore_defs_h = $(embedStringFile "rts/c/multicore_defs.h")-          multicore_util_h = $(embedStringFile "rts/c/multicore_util.h")-          subtask_queue_h = $(embedStringFile "rts/c/subtask_queue.h")-          scheduler_common_h = $(embedStringFile "rts/c/scheduler_common.h")-          scheduler_h = $(embedStringFile "rts/c/scheduler.h")-          scheduler_tune_h = $(embedStringFile "rts/c/scheduler_tune.h")--      mapM_-        GC.earlyDecl-        [C.cunit|-                              $esc:multicore_defs_h-                              $esc:multicore_util_h-                              $esc:subtask_queue_h-                              $esc:scheduler_common_h-                              $esc:scheduler_h-                             |]--      mapM_ GC.earlyDecl [C.cunit|int futhark_segred_tuning_program(struct futhark_context *ctx);|]-      mapM_ GC.libDecl [C.cunit|$esc:scheduler_tune_h|]+      let scheduler_h = $(embedStringFile "rts/c/scheduler.h")+      mapM_ GC.earlyDecl [C.cunit|$esc:scheduler_h|]        cfg <- GC.publicDef "context_config" GC.InitDecl $ \s ->         ( [C.cedecl|struct $id:s;|],-          [C.cedecl|struct $id:s { int debugging; int profiling; };|]+          [C.cedecl|struct $id:s { int debugging;+                                   int profiling;+                                   int num_threads;+                                 };|]         )        GC.publicDef_ "context_config_new" GC.InitDecl $ \s ->@@ -77,6 +63,7 @@                                  }                                  cfg->debugging = 0;                                  cfg->profiling = 0;+                                 cfg->num_threads = 0;                                  return cfg;                                }|]         )@@ -110,6 +97,13 @@                                }|]         ) +      GC.publicDef_ "context_config_set_num_threads" GC.InitDecl $ \s ->+        ( [C.cedecl|void $id:s(struct $id:cfg *cfg, int n);|],+          [C.cedecl|void $id:s(struct $id:cfg *cfg, int n) {+                                 cfg->num_threads = n;+                               }|]+        )+       (fields, init_fields) <- GC.contextContents        ctx <- GC.publicDef "context" GC.InitDecl $ \s ->@@ -148,38 +142,26 @@                  ctx->profiling_paused = 0;                  ctx->error = NULL;                  create_lock(&ctx->lock);-                 ctx->scheduler.num_threads = num_processors();-                 if (ctx->scheduler.num_threads < 1) return NULL; -                 $stms:init_fields--                 // futhark_segred_tuning_program(ctx);--                 ctx->scheduler.workers = calloc(ctx->scheduler.num_threads, sizeof(struct worker));-                 if (ctx->scheduler.workers == NULL) return NULL;-                 num_workers = ctx->scheduler.num_threads;--                 worker_local = &ctx->scheduler.workers[0];-                 worker_local->tid = 0;-                 worker_local->scheduler = &ctx->scheduler;-                 CHECK_ERR(subtask_queue_init(&worker_local->q, 1024), "failed to init queue for worker %d\n", 0);-+                 int tune_kappa = 0;+                 double kappa = 5.1f * 1000; -                 for (int i = 1; i < ctx->scheduler.num_threads; i++) {-                   struct worker *cur_worker = &ctx->scheduler.workers[i];-                   memset(cur_worker, 0, sizeof(struct worker));-                   cur_worker->tid = i;-                   cur_worker->output_usage = 0;-                   cur_worker->scheduler = &ctx->scheduler;-                   CHECK_ERR(subtask_queue_init(&cur_worker->q, 1024), "failed to init queue for worker %d\n", i);+                 if (tune_kappa) {+                   if (determine_kappa(&kappa) != 0) {+                     return NULL;+                   }+                 } -                   CHECK_ERR(pthread_create(&cur_worker->thread, NULL, &scheduler_worker,-                                            cur_worker),-                             "Failed to create worker %d\n", i);+                 if (scheduler_init(&ctx->scheduler,+                                    cfg->num_threads > 0 ?+                                    cfg->num_threads : num_processors(),+                                    kappa) != 0) {+                   return NULL;                  } -                 init_constants(ctx);+                 $stms:init_fields +                 init_constants(ctx);                   return ctx;               }|]@@ -189,18 +171,7 @@         ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],           [C.cedecl|void $id:s(struct $id:ctx* ctx) {                  free_constants(ctx);--                 // output_thread_usage(worker_local);-                 for (int i = 1; i < ctx->scheduler.num_threads; i++)-                 {-                   struct worker *cur_worker = &ctx->scheduler.workers[i];-                   cur_worker->dead = 1;-                   subtask_queue_destroy(&cur_worker->q);-                   CHECK_ERR(pthread_join(ctx->scheduler.workers[i].thread, NULL), "pthread_join");-                 }---                 free(ctx->scheduler.workers);+                 (void)scheduler_destroy(&ctx->scheduler);                  free_lock(&ctx->lock);                  free(ctx);                }|]@@ -222,6 +193,13 @@         optionArgument = NoArgument,         optionAction = [C.cstm|futhark_context_config_set_profiling(cfg, 1);|],         optionDescription = "Gather profiling information."+      },+    Option+      { optionLongName = "num-threads",+        optionShortName = Nothing,+        optionArgument = RequiredArgument "INT",+        optionAction = [C.cstm|futhark_context_config_set_num_threads(cfg, atoi(optarg));|],+        optionDescription = "Set number of threads used for execution."       }   ] @@ -428,7 +406,7 @@   addBenchmarkFields name tid   return     [C.citems|-     typename uint64_t $id:start;+     typename uint64_t $id:start = 0;      if (ctx->profiling && !ctx->profiling_paused) {        $id:start = get_wall_time();      }@@ -473,7 +451,7 @@   GC.libDecl =<< f s'   return s' -generateFunction ::+generateParLoopFn ::   C.ToIdent a =>   M.Map VName Space ->   String ->@@ -484,7 +462,7 @@   VName ->   VName ->   GC.CompilerM Multicore s Name-generateFunction lexical basename code fstruct free retval tid ntasks = do+generateParLoopFn lexical basename code fstruct free retval tid ntasks = do   let (fargs, fctypes) = unzip free   let (retval_args, retval_ctypes) = unzip retval   multicoreDef basename $ \s -> do@@ -549,7 +527,7 @@   fstruct <-     prepareTaskStruct "task" free_args free_ctypes retval_args retval_ctypes -  fpar_task <- generateFunction lexical (name ++ "_task") seq_code fstruct free retval tid nsubtask+  fpar_task <- generateParLoopFn lexical (name ++ "_task") seq_code fstruct free retval tid nsubtask   addTimingFields fpar_task    let ftask_name = fstruct <> "_task"@@ -570,7 +548,7 @@   fnpar_task <- case par_task of     Just (ParallelTask nested_code nested_tid) -> do       let lexical_nested = lexicalMemoryUsage $ Function False [] params nested_code [] []-      fnpar_task <- generateFunction lexical_nested (name ++ "_nested_task") nested_code fstruct free retval nested_tid nsubtask+      fnpar_task <- generateParLoopFn lexical_nested (name ++ "_nested_task") nested_code fstruct free retval nested_tid nsubtask       GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|]       return $ zip [fnpar_task] [True]     Nothing -> do@@ -623,7 +601,7 @@           mapM_ GC.stm free_cached      return-      [C.cedecl|int $id:s(void *args, typename int64_t start, typename int64_t end, int $id:tid, int tid) {+      [C.cedecl|static int $id:s(void *args, typename int64_t start, typename int64_t end, int $id:tid, int tid) {                        int err = 0;                        struct $id:fstruct *$id:fstruct = (struct $id:fstruct*) args;                        struct futhark_context *ctx = $id:fstruct->ctx;@@ -645,7 +623,8 @@     benchmarkCode       ftask_total       Nothing-      [C.citems|int $id:ftask_err = scheduler_execute_task(&ctx->scheduler, &$id:ftask_name);+      [C.citems|int $id:ftask_err = scheduler_execute_task(&ctx->scheduler,+                                                           &$id:ftask_name);                if ($id:ftask_err != 0) {                  err = 1;                  goto cleanup;

@@ -126,6 +126,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S+import Data.String import Futhark.CodeGen.ImpCode   ( Bytes,     Count,@@ -394,7 +395,7 @@ -- | Emit a warning about something the user should be aware of. warn :: Located loc => loc -> [loc] -> String -> ImpM lore r op () warn loc locs problem =-  warnings $ singleWarning' (srclocOf loc) (map srclocOf locs) problem+  warnings $ singleWarning' (srclocOf loc) (map srclocOf locs) (fromString problem)  -- | Emit a function in the generated code. emitFunction :: Name -> Imp.Function op -> ImpM lore r op ()@@ -1087,9 +1088,6 @@    -- | Compile where we know the type in advance.   toExp' :: PrimType -> a -> Imp.Exp--  toInt32Exp :: a -> Imp.TExp Int32-  toInt32Exp = TPrimExp . toExp' int32    toInt64Exp :: a -> Imp.TExp Int64   toInt64Exp = TPrimExp . toExp' int64

@@ -110,11 +110,8 @@   -- The calculations are done with 64-bit integers to avoid overflow   -- issues.   let num_groups_maybe_zero =-        sMin64-          ( toInt64Exp w64-              `divUp` sExt64 (toInt32Exp group_size)-          )-          $ sExt64 (tvExp max_num_groups)+        sMin64 (toInt64Exp w64 `divUp` toInt64Exp group_size) $+          sExt64 (tvExp max_num_groups)   -- We also don't want zero groups.   let num_groups = sMax64 1 num_groups_maybe_zero   mkTV (patElemName pe) int32 <-- sExt32 num_groups

@@ -1072,8 +1072,9 @@     -- Compute RF as the average RF over all the histograms.     hist_RF <-       dPrimVE "hist_RF" $-        sum (map (toInt32Exp . histRaceFactor . slugOp) slugs)-          `quot` genericLength slugs+        sExt32 $+          sum (map (toInt64Exp . histRaceFactor . slugOp) slugs)+            `quot` genericLength slugs      let hist_T = sExt32 $ unCount num_groups' * unCount group_size'     emit $ Imp.DebugPrint "\n# SegHist" Nothing

@@ -53,7 +53,7 @@ compileMCOp _ (OtherOp ()) = pure () compileMCOp pat (ParOp par_op op) = do   let space = getSpace op-  dPrimV_ (segFlat space) (0 :: Imp.TExp Int32)+  dPrimV_ (segFlat space) (0 :: Imp.TExp Int64)   iterations <- getIterationDomain op space   nsubtasks <- dPrim "num_tasks" $ IntType Int32   seq_code <- compileSegOp pat op nsubtasks@@ -64,7 +64,7 @@   par_code <- case par_op of     Just nested_op -> do       let space' = getSpace nested_op-      dPrimV_ (segFlat space') (0 :: Imp.TExp Int32)+      dPrimV_ (segFlat space') (0 :: Imp.TExp Int64)       compileSegOp pat nested_op nsubtasks     Nothing -> return mempty 

@@ -70,11 +70,11 @@ getIterationDomain :: SegOp () MCMem -> SegSpace -> MulticoreGen (Imp.TExp Int64) getIterationDomain SegMap {} space = do   let ns = map snd $ unSegSpace space-      ns_64 = map (sExt64 . toInt32Exp) ns+      ns_64 = map toInt64Exp ns   return $ product ns_64 getIterationDomain _ space = do   let ns = map snd $ unSegSpace space-      ns_64 = map (sExt64 . toInt32Exp) ns+      ns_64 = map toInt64Exp ns   case unSegSpace space of     [_] -> return $ product ns_64     -- A segmented SegOp is over the segments

@@ -49,12 +49,14 @@    histops' <- renameHistOpLambda histops -  collect $ do-    flat_idx <- dPrim "iter" int64-    sIf-      use_subhistogram-      (subHistogram pat flat_idx space histops num_histos kbody)-      (atomicHistogram pat flat_idx space histops' kbody)+  -- Only do something if there is actually input.+  collect $+    sUnless (product ns_64 .==. 0) $ do+      flat_idx <- dPrim "iter" int64+      sIf+        use_subhistogram+        (subHistogram pat flat_idx space histops num_histos kbody)+        (atomicHistogram pat flat_idx space histops' kbody)  -- | -- Atomic Histogram approach

@@ -95,7 +95,7 @@   MulticoreGen () reductionStage1 space slugs kbody = do   let (is, ns) = unzip $ unSegSpace space-      ns' = map (sExt64 . toInt32Exp) ns+      ns' = map toInt64Exp ns   flat_idx <- dPrim "iter" int64    -- Create local accumulator variables in which we carry out the

@@ -66,7 +66,7 @@       per_scan_pes = segBinOpChunks scan_ops $ patternValueElements pat   let (is, ns) = unzip $ unSegSpace space       ns' = map toInt64Exp ns-  iter <- dPrim "iter" $ IntType Int32+  iter <- dPrim "iter" $ IntType Int64    -- Stage 1 : each thread partially scans a chunk of the input   -- Writes directly to the resulting array

@@ -31,6 +31,7 @@ import qualified Futhark.TypeCheck as I import Futhark.Util.Log import Futhark.Util.Pretty (ppr, prettyText)+import Language.Futhark.Warnings import System.Exit (ExitCode (..), exitWith) import System.IO @@ -180,9 +181,9 @@ handleWarnings config m = do   (ws, a) <- m -  when (futharkWarn config) $ do-    liftIO $ hPutStr stderr $ show ws-    when (futharkWerror config && ws /= mempty) $+  when (futharkWarn config && anyWarnings ws) $ do+    liftIO $ hPutStrLn stderr $ pretty ws+    when (futharkWerror config) $       externalErrorS "Treating above warnings as errors due to --Werror."    return a

@@ -26,12 +26,13 @@ import qualified Data.Text.IO as T import Futhark.Error import Futhark.FreshNames-import Futhark.Util.Pretty (ppr)+import Futhark.Util.Pretty (line, ppr, (</>)) import qualified Language.Futhark as E import Language.Futhark.Parser import Language.Futhark.Prelude import Language.Futhark.Semantic import qualified Language.Futhark.TypeChecker as E+import Language.Futhark.Warnings import qualified System.FilePath.Posix as Posix import System.IO.Error @@ -104,9 +105,14 @@   roots <- ask    case E.checkProg imports src include $ prependRoots roots prog of-    Left err ->-      externalError $ ppr err-    Right (m, ws, src') ->+    (prog_ws, Left err) -> do+      prev_ws <- gets warnings+      let ws = prev_ws <> prog_ws+      externalError $+        if anyWarnings ws+          then ppr (prev_ws <> ws) </> line <> ppr err+          else ppr err+    (ws, Right (m, src')) ->       modify $ \s ->         s           { alreadyImported = (includeToString include, m) : imports,

@@ -108,6 +108,7 @@ import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer+import Data.Bifunctor (second) import Data.List (sortOn) import qualified Data.Map.Strict as M import Futhark.Binder@@ -576,11 +577,14 @@   [TypeBase ExtShape u] ->   m ([TypeBase Shape u], [Ident]) instantiateShapes' ts =-  runWriterT $ instantiateShapes instantiate ts+  -- Carefully ensure that the order of idents we produce corresponds+  -- to their existential index.+  second (map snd . sortOn fst)+    <$> runWriterT (instantiateShapes instantiate ts)   where-    instantiate _ = do+    instantiate x = do       v <- lift $ newIdent "size" $ Prim int64-      tell [v]+      tell [(x, v)]       return $ Var $ identName v  removeExistentials :: ExtType -> Type -> Type

@@ -86,7 +86,7 @@ -- can generate an index. type Documented = M.Map VName IndexWhat -warn :: SrcLoc -> String -> DocM ()+warn :: SrcLoc -> Doc -> DocM () warn loc s = lift $ lift $ tell $ singleWarning loc s  document :: VName -> IndexWhat -> DocM ()@@ -724,17 +724,17 @@         case maybe_v of           Nothing -> do             warn loc $-              "Identifier '" <> name <> "' not found in namespace '"-                <> namespace+              "Identifier '" <> fromString name <> "' not found in namespace '"+                <> fromString namespace                 <> "'"-                <> maybe "" (" in file " <>) file+                <> fromString (maybe "" (" in file " <>) file)                 <> "."             unknown           Just v' -> do             link <- vnameLink v'             proceed $ "[`" <> name <> "`](" <> link <> ")"       _ -> do-        warn loc $ "Unknown namespace '" <> namespace <> "'."+        warn loc $ "Unknown namespace '" <> fromString namespace <> "'."         unknown   where     knownNamespace "term" = Just Term

@@ -87,7 +87,7 @@         Nothing -> return $ errorMsg ["Function return value does not match shape of declared return type."]        ((rettype', body_res), body_stms) <- collectStms $ do-        body_res <- internaliseExp "res" body+        body_res <- internaliseExp (baseString fname <> "_res") body         rettype_bad <- internaliseReturnType rettype         let rettype' = zeroExts rettype_bad         return (rettype', body_res)@@ -319,8 +319,9 @@           ++ locStr loc           ++ "." -internaliseBody :: E.Exp -> InternaliseM Body-internaliseBody e = insertStmsM $ resultBody <$> internaliseExp "res" e+internaliseBody :: String -> E.Exp -> InternaliseM Body+internaliseBody desc e =+  insertStmsM $ resultBody <$> internaliseExp (desc <> "_res") e  bodyFromStms ::   InternaliseM (Result, a) ->@@ -888,7 +889,7 @@         let CasePat pLast eLast _ = NE.last cs'         bFalse <- do           (_, pertinent) <- generateCond pLast ses-          eLast' <- internalisePat' pLast pertinent eLast internaliseBody+          eLast' <- internalisePat' pLast pertinent eLast (internaliseBody desc)           foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $             reverse $ NE.init cs'         letTupExp' desc =<< generateCaseIf ses c bFalse@@ -918,8 +919,8 @@     letTupExp' desc       =<< eIf         (BasicOp . SubExp <$> internaliseExp1 "cond" ce)-        (internaliseBody te)-        (internaliseBody fe)+        (internaliseBody (desc <> "_t") te)+        (internaliseBody (desc <> "_f") fe)   bindExtSizes (E.toStruct ret) retext ses   return ses @@ -990,8 +991,11 @@   return (cmp, pertinent)   where     -- Literals are always primitive values.-    compares (E.PatternLit e _ _) (se : ses) = do-      e' <- internaliseExp1 "constant" e+    compares (E.PatternLit l t _) (se : ses) = do+      e' <- case l of+        PatLitPrim v -> pure $ constant $ internalisePrimValue v+        PatLitInt x -> internaliseExp1 "constant" $ E.IntLit x t mempty+        PatLitFloat x -> internaliseExp1 "constant" $ E.FloatLit x t mempty       t' <- elemType <$> subExpType se       cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se       return ([cmp], [se], ses)@@ -1038,7 +1042,7 @@ generateCaseIf :: [I.SubExp] -> Case -> I.Body -> InternaliseM I.Exp generateCaseIf ses (CasePat p eCase _) bFail = do   (cond, pertinent) <- generateCond p ses-  eCase' <- internalisePat' p pertinent eCase internaliseBody+  eCase' <- internalisePat' p pertinent eCase (internaliseBody "case")   eIf (eSubExp cond) (return eCase') (return bFail)  internalisePat ::@@ -1626,7 +1630,7 @@   internaliseLambda e rowtypes internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =   bindingLambdaParams params rowtypes $ \params' -> do-    body' <- internaliseBody body+    body' <- internaliseBody "lam" body     rettype' <- internaliseLambdaReturnType rettype     return (params', body', rettype') internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e

@@ -66,6 +66,70 @@ isGlobal :: VName -> DefM a -> DefM a isGlobal v = local $ Arrow.first (S.insert v) +replaceStaticValSizes :: M.Map VName VName -> StaticVal -> StaticVal+replaceStaticValSizes substs sv =+  case sv of+    LambdaSV sizes param t e closure_env ->+      LambdaSV+        sizes+        (onAST param)+        (onType t)+        (onExtExp e)+        (onEnv closure_env)+    Dynamic t ->+      Dynamic $ onType t+    RecordSV fs ->+      RecordSV $ map (fmap (replaceStaticValSizes substs)) fs+    SumSV c svs ts ->+      SumSV c (map (replaceStaticValSizes substs) svs) $+        map (fmap (map onType)) ts+    DynamicFun (e, sv1) sv2 ->+      DynamicFun (onAST e, replaceStaticValSizes substs sv1) $+        replaceStaticValSizes substs sv2+    IntrinsicSV ->+      IntrinsicSV+  where+    onName v = fromMaybe v $ M.lookup v substs+    onQualName v = maybe v qualName $ M.lookup (qualLeaf v) substs++    tv =+      identityMapper+        { mapOnPatternType = pure . onType,+          mapOnStructType = pure . onType,+          mapOnQualName = pure . onQualName,+          mapOnExp = pure . onAST+        }++    onExtExp (ExtExp e) =+      ExtExp $ onAST e+    onExtExp (ExtLambda dims params e (als, t) loc) =+      ExtLambda dims (map onAST params) (onAST e) (als, onType t) loc++    onEnv =+      M.fromList+        . map (bimap onName $ replaceStaticValSizes substs)+        . M.toList++    onAST :: ASTMappable x => x -> x+    onAST = runIdentity . astMap tv++    onType = first onDim+      where+        onDim (NamedDim v) =+          NamedDim $ maybe v qualName $ M.lookup (qualLeaf v) substs+        onDim d = d++-- | Construct new sizes for a LambdaSV (if that is what it is).  This+-- is needed because sizes must be unique when we substitute the+-- closure for the LambdaSV into another function, because sizes float+-- to the top (see issue #1147).+newSizesForLambda :: StaticVal -> DefM StaticVal+newSizesForLambda (LambdaSV sizes param t e closure_env) = do+  sizes' <- mapM newName sizes+  let substs = M.fromList $ zip sizes sizes'+  pure $ replaceStaticValSizes substs $ LambdaSV sizes' param t e closure_env+newSizesForLambda sv = pure sv+ -- | Returns the defunctionalization environment restricted -- to the given set of variable names and types. restrictEnvTo :: NameSet -> DefM Env@@ -517,7 +581,8 @@ defuncExtExp :: ExtExp -> DefM (Exp, StaticVal) defuncExtExp (ExtExp e) = defuncExp e defuncExtExp (ExtLambda tparams pats e0 (closure, ret) loc) =-  defuncFun tparams pats e0 (closure, ret) loc+  traverse newSizesForLambda+    =<< defuncFun tparams pats e0 (closure, ret) loc  defuncCase :: StaticVal -> Case -> DefM (Case, StaticVal) defuncCase sv (CasePat p e loc) = do@@ -731,7 +796,7 @@     -- If e1 is a dynamic function, we just leave the application in place,     -- but we update the types since it may be partially applied or return     -- a higher-order term.-    DynamicFun _ sv ->+    DynamicFun _ sv -> do       let (argtypes', rettype) = dynamicFunType sv argtypes           restype = foldFunType argtypes' rettype `setAliases` aliases ret           -- FIXME: what if this application returns both a function@@ -740,7 +805,8 @@             | orderZero ret = (Info ret, Info ext)             | otherwise = (Info restype, Info ext)           apply_e = Apply e1' e2' d callret loc-       in return (apply_e, sv)+      sv' <- newSizesForLambda sv+      return (apply_e, sv')     -- Propagate the 'IntrinsicsSV' until we reach the outermost application,     -- where we construct a dynamic static value with the appropriate type.     IntrinsicSV@@ -1123,9 +1189,11 @@       <> ( (names (patternDimNames pat) <> freeVars e2)              `without` patternVars pat          )-  LetFun vn (_, pats, _, _, e1) e2 _ _ ->+  LetFun vn (tparams, pats, _, _, e1) e2 _ _ ->     ( (freeVars e1 <> names (foldMap patternDimNames pats))-        `without` foldMap patternVars pats+        `without` ( foldMap patternVars pats+                      <> foldMap (oneName . typeParamName) tparams+                  )     )       <> (freeVars e2 `without` oneName vn)   If e1 e2 e3 _ _ -> freeVars e1 <> freeVars e2 <> freeVars e3

@@ -329,7 +329,7 @@     <*> pure (Info t', retext)     <*> pure loc transformExp (LetFun fname (tparams, params, retdecl, Info ret, body) e e_t loc)-  | any isTypeParam tparams = do+  | not $ null tparams = do     -- Retrieve the lifted monomorphic function bindings that are produced,     -- filter those that are monomorphic versions of the current let-bound     -- function and insert them at this point, and propagate the rest.

@@ -131,8 +131,8 @@           (slice', bodystms) <-             flip runBinderT scope $               traverse (toSubExp "index") $-                fixSlice (map (fmap pe32) slice) $-                  map (pe32 . Var) gtids+                fixSlice (map (fmap pe64) slice) $+                  map (pe64 . Var) gtids            let res_dims = arrayDims $ snd bindee_dec               ret' = WriteReturns res_dims src [(map DimFix slice', se)]

@@ -17,6 +17,7 @@ import Futhark.Construct import Futhark.IR import Futhark.IR.Prop.Aliases+import Futhark.Transform.Substitute import Futhark.Util  type IndexSubstitution dec = (Certificates, VName, dec, Slice SubExp)@@ -87,6 +88,15 @@   IndexSubstitutions (LetDec (Lore m)) ->   Exp (Lore m) ->   m (Exp (Lore m))+substituteIndicesInExp substs (Op op) = do+  let used_in_op = filter ((`nameIn` freeIn op) . fst) substs+  var_substs <- fmap mconcat $+    forM used_in_op $ \(v, (cs, src, src_dec, is)) -> do+      v' <-+        certifying cs $+          letExp "idx" $ BasicOp $ Index src $ fullSlice (typeOf src_dec) is+      pure $ M.singleton v v'+  pure $ Op $ substituteNames var_substs op substituteIndicesInExp substs e = do   substs' <- copyAnyConsumed e   let substitute =

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}  -- | Perform a restricted form of loop tiling within SegMaps.  We only@@ -9,6 +10,7 @@ import Control.Monad.State import Data.List (foldl') import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe) import qualified Data.Sequence as Seq import Futhark.IR.Kernels import Futhark.MonadFreshNames@@ -101,52 +103,50 @@     descend _ [] =       return Nothing     descend prestms (stm_to_tile : poststms)-      -- 1D tiling of redomap.-      | (gtid, kdim) : top_space_rev <- reverse $ unSegSpace initial_space,+      -- 2D tiling of redomap.+      | (gtids, kdims) <- unzip $ unSegSpace initial_space,         Just (w, arrs, form) <- tileable stm_to_tile,-        not $-          any-            ( nameIn gtid-                . flip (M.findWithDefault mempty) variance-            )-            arrs,-        not $ gtid `nameIn` branch_variant,+        Just inputs <-+          mapM (invariantToOneOfTwoInnerDims branch_variant variance gtids) arrs,+        not $ null $ tiledInputs inputs,+        gtid_y : gtid_x : top_gtids_rev <- reverse gtids,+        kdim_y : kdim_x : top_kdims_rev <- reverse kdims,         (prestms', poststms') <-           preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms),         used <- freeIn stm_to_tile <> freeIn poststms' <> freeIn stms_res =         Just . injectPrelude initial_space private variance prestms' used           <$> tileGeneric-            (tiling1d $ reverse top_space_rev)+            (tiling2d $ reverse $ zip top_gtids_rev top_kdims_rev)             initial_lvl             res_ts             (stmPattern stm_to_tile)-            gtid-            kdim+            (gtid_x, gtid_y)+            (kdim_x, kdim_y)             w             form-            (zip arrs $ repeat [0])+            inputs             poststms'             stms_res-      -- 2D tiling of redomap.-      | (gtids, kdims) <- unzip $ unSegSpace initial_space,+      -- 1D tiling of redomap.+      | (gtid, kdim) : top_space_rev <- reverse $ unSegSpace initial_space,         Just (w, arrs, form) <- tileable stm_to_tile,-        Just inner_perm <- mapM (invariantToOneOfTwoInnerDims branch_variant variance gtids) arrs,-        gtid_y : gtid_x : top_gtids_rev <- reverse gtids,-        kdim_y : kdim_x : top_kdims_rev <- reverse kdims,+        inputs <- map (is1DTileable gtid variance) arrs,+        not $ null $ tiledInputs inputs,+        not $ gtid `nameIn` branch_variant,         (prestms', poststms') <-           preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms),         used <- freeIn stm_to_tile <> freeIn poststms' <> freeIn stms_res =         Just . injectPrelude initial_space private variance prestms' used           <$> tileGeneric-            (tiling2d $ reverse $ zip top_gtids_rev top_kdims_rev)+            (tiling1d $ reverse top_space_rev)             initial_lvl             res_ts             (stmPattern stm_to_tile)-            (gtid_x, gtid_y)-            (kdim_x, kdim_y)+            gtid+            kdim             w             form-            (zip arrs inner_perm)+            inputs             poststms'             stms_res       -- Tiling inside for-loop.@@ -453,6 +453,50 @@   | otherwise =     Nothing +-- | We classify the inputs to the tiled loop as whether they are+-- tileable (and with what permutation of the kernel indexes) or not.+-- In practice, we should have at least one tileable array per loop,+-- but this is not enforced in our representation.+data InputArray+  = InputTile [Int] VName+  | InputDontTile VName++tiledInputs :: [InputArray] -> [(VName, [Int])]+tiledInputs = mapMaybe f+  where+    f (InputTile perm arr) = Just (arr, perm)+    f InputDontTile {} = Nothing++-- | A tile (or an original untiled array).+data InputTile+  = InputTiled [Int] VName+  | InputUntiled VName++-- First VNames are the tiles, second are the untiled.+inputsToTiles :: [InputArray] -> [VName] -> [InputTile]+inputsToTiles (InputTile perm _ : inputs) (tile : tiles) =+  InputTiled perm tile : inputsToTiles inputs tiles+inputsToTiles (InputDontTile arr : inputs) tiles =+  InputUntiled arr : inputsToTiles inputs tiles+inputsToTiles _ _ = []++-- The atual tile size may be smaller for the last tile, so we have to+-- be careful now.+sliceUntiled ::+  MonadBinder m =>+  VName ->+  SubExp ->+  SubExp ->+  SubExp ->+  m VName+sliceUntiled arr tile_id full_tile_size this_tile_size = do+  arr_t <- lookupType arr+  slice_offset <-+    letSubExp "slice_offset" =<< toExp (pe64 tile_id * pe64 full_tile_size)+  let slice = DimSlice slice_offset this_tile_size (intConst Int64 1)+  letExp "untiled_slice" $+    BasicOp $ Index arr $ fullSlice arr_t [slice]+ -- | Statements that we insert directly into every thread-private -- SegMaps.  This is for things that cannot efficiently be computed -- once in advance in the prelude SegMap, primarily (exclusively?)@@ -479,6 +523,27 @@  type ReadPrelude = Slice SubExp -> Binder Kernels () +data ProcessTileArgs = ProcessTileArgs+  { processPrivStms :: PrivStms,+    processComm :: Commutativity,+    processRedLam :: Lambda Kernels,+    processMapLam :: Lambda Kernels,+    processTiles :: [InputTile],+    processAcc :: [VName],+    processTileId :: SubExp+  }++data ResidualTileArgs = ResidualTileArgs+  { residualPrivStms :: PrivStms,+    residualComm :: Commutativity,+    residualRedLam :: Lambda Kernels,+    residualMapLam :: Lambda Kernels,+    residualInput :: [InputArray],+    residualAcc :: [VName],+    residualInputSize :: SubExp,+    residualNumWholeTiles :: SubExp+  }+ -- | Information about a loop that has been tiled inside a kernel, as -- well as the kinds of changes that we would then like to perform on -- the kernel.@@ -495,25 +560,13 @@       TileKind ->       PrivStms ->       SubExp ->-      [(VName, [Int])] ->-      Binder Kernels [VName],+      [InputArray] ->+      Binder Kernels [InputTile],     tilingProcessTile ::-      PrivStms ->-      Commutativity ->-      Lambda Kernels ->-      Lambda Kernels ->-      [(VName, [Int])] ->-      [VName] ->+      ProcessTileArgs ->       Binder Kernels [VName],     tilingProcessResidualTile ::-      PrivStms ->-      Commutativity ->-      Lambda Kernels ->-      Lambda Kernels ->-      SubExp ->-      [VName] ->-      SubExp ->-      [(VName, [Int])] ->+      ResidualTileArgs ->       Binder Kernels [VName],     tilingTileReturns :: VName -> Binder Kernels KernelResult,     tilingSpace :: SegSpace,@@ -578,11 +631,11 @@   kdims ->   SubExp ->   (Commutativity, Lambda Kernels, [SubExp], Lambda Kernels) ->-  [(VName, [Int])] ->+  [InputArray] ->   Stms Kernels ->   Result ->   TileM (Stms Kernels, Tiling, TiledBody)-tileGeneric doTiling initial_lvl res_ts pat gtids kdims w form arrs_and_perms poststms poststms_res = do+tileGeneric doTiling initial_lvl res_ts pat gtids kdims w form inputs poststms poststms_res = do   (tiling, tiling_stms) <- runBinder $ doTiling initial_lvl gtids kdims w    return (tiling_stms, tiling, tiledBody tiling)@@ -619,36 +672,24 @@         inScopeOf loopform $           localScope (scopeOfFParams $ map fst merge) $ do             -- Collectively read a tile.-            tile <- tilingReadTile tiling TilePartial privstms (Var tile_id) arrs_and_perms+            tile <- tilingReadTile tiling TilePartial privstms (Var tile_id) inputs              -- Now each thread performs a traversal of the tile and             -- updates its accumulator.-            resultBody . map Var-              <$> tilingProcessTile-                tiling-                privstms-                red_comm-                red_lam-                map_lam-                (zip tile (map snd arrs_and_perms))-                (map (paramName . fst) merge)+            let accs =+                  map (paramName . fst) merge+                tile_args =+                  ProcessTileArgs privstms red_comm red_lam map_lam tile accs (Var tile_id)+            resultBody . map Var <$> tilingProcessTile tiling tile_args        accs <- letTupExp "accs" $ DoLoop [] merge loopform loopbody        -- We possibly have to traverse a residual tile.       red_lam' <- renameLambda red_lam       map_lam' <- renameLambda map_lam-      accs' <--        tilingProcessResidualTile-          tiling-          privstms-          red_comm-          red_lam'-          map_lam'-          num_whole_tiles-          accs-          w-          arrs_and_perms+      let residual_args =+            ResidualTileArgs privstms red_comm red_lam' map_lam' inputs accs w num_whole_tiles+      accs' <- tilingProcessResidualTile tiling residual_args        -- Create a SegMap that takes care of the postlude for every thread.       postludeGeneric tiling privstms pat accs' poststms poststms_res res_ts@@ -675,6 +716,13 @@   let tile_dims = zip (map snd dims_on_top) unit_dims ++ dims   return $ TileReturns tile_dims arr' +is1DTileable :: VName -> M.Map VName Names -> VName -> InputArray+is1DTileable gtid variance arr+  | not $ nameIn gtid $ M.findWithDefault mempty arr variance =+    InputTile [0] arr+  | otherwise =+    InputDontTile arr+ segMap1D ::   String ->   SegLevel ->@@ -716,19 +764,12 @@   TileKind ->   PrivStms ->   SubExp ->-  [(VName, [Int])] ->-  Binder Kernels [VName]-readTile1D-  tile_size-  gid-  gtid-  num_groups-  group_size-  kind-  privstms-  tile_id-  arrs_and_perms =-    segMap1D "full_tile" (SegThread num_groups group_size SegNoVirt) ResultNoSimplify $ \ltid -> do+  [InputArray] ->+  Binder Kernels [InputTile]+readTile1D tile_size gid gtid num_groups group_size kind privstms tile_id inputs =+  fmap (inputsToTiles inputs)+    . segMap1D "full_tile" lvl ResultNoSimplify+    $ \ltid -> do       j <-         letSubExp "j"           =<< toExp (pe64 tile_id * pe64 tile_size + le64 ltid)@@ -736,14 +777,14 @@       reconstructGtids1D group_size gtid gid ltid       addPrivStms [DimFix $ Var ltid] privstms -      let arrs = map fst arrs_and_perms+      let arrs = map fst $ tiledInputs inputs       arr_ts <- mapM lookupType arrs       let tile_ts = map rowType arr_ts           w = arraysSize 0 arr_ts        let readTileElem arr =             -- No need for fullSlice because we are tiling only prims.-            letExp "tile_elem" $ BasicOp $ Index arr [DimFix j]+            letExp "tile_elem" (BasicOp $ Index arr [DimFix j])       fmap (map Var) $         case kind of           TilePartial ->@@ -754,6 +795,8 @@                 (eBody $ map eBlank tile_ts)           TileFull ->             mapM readTileElem arrs+  where+    lvl = SegThread num_groups group_size SegNoVirt  processTile1D ::   VName ->@@ -762,46 +805,43 @@   SubExp ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->-  PrivStms ->-  Commutativity ->-  Lambda Kernels ->-  Lambda Kernels ->-  [(VName, [Int])] ->-  [VName] ->+  ProcessTileArgs ->   Binder Kernels [VName]-processTile1D-  gid-  gtid-  kdim-  tile_size-  num_groups-  group_size-  privstms-  red_comm-  red_lam-  map_lam-  tiles_and_perm-  accs = do-    let tile = map fst tiles_and_perm+processTile1D gid gtid kdim tile_size num_groups group_size tile_args = do+  let red_comm = processComm tile_args+      privstms = processPrivStms tile_args+      map_lam = processMapLam tile_args+      red_lam = processRedLam tile_args+      tiles = processTiles tile_args+      tile_id = processTileId tile_args+      accs = processAcc tile_args -    segMap1D "acc" (SegThread num_groups group_size SegNoVirt) ResultPrivate $ \ltid -> do-      reconstructGtids1D group_size gtid gid ltid-      addPrivStms [DimFix $ Var ltid] privstms+  segMap1D "acc" lvl ResultPrivate $ \ltid -> do+    reconstructGtids1D group_size gtid gid ltid+    addPrivStms [DimFix $ Var ltid] privstms -      -- We replace the neutral elements with the accumulators (this is-      -- OK because the parallel semantics are not used after this-      -- point).-      thread_accs <- forM accs $ \acc ->-        letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid]-      let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam+    -- We replace the neutral elements with the accumulators (this is+    -- OK because the parallel semantics are not used after this+    -- point).+    thread_accs <- forM accs $ \acc ->+      letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid]+    let sliceTile (InputTiled _ arr) =+          pure arr+        sliceTile (InputUntiled arr) =+          sliceUntiled arr tile_id tile_size tile_size -      fmap (map Var) $-        letTupExp "acc"-          =<< eIf-            (toExp $ le64 gtid .<. pe64 kdim)-            (eBody [pure $ Op $ OtherOp $ Screma tile_size form' tile])-            (resultBodyM thread_accs)+    tiles' <- mapM sliceTile tiles +    let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam+    fmap (map Var) $+      letTupExp "acc"+        =<< eIf+          (toExp $ le64 gtid .<. pe64 kdim)+          (eBody [pure $ Op $ OtherOp $ Screma tile_size form' tiles'])+          (resultBodyM thread_accs)+  where+    lvl = SegThread num_groups group_size SegNoVirt+ processResidualTile1D ::   VName ->   VName ->@@ -809,80 +849,62 @@   SubExp ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->-  PrivStms ->-  Commutativity ->-  Lambda Kernels ->-  Lambda Kernels ->-  SubExp ->-  [VName] ->-  SubExp ->-  [(VName, [Int])] ->+  ResidualTileArgs ->   Binder Kernels [VName]-processResidualTile1D-  gid-  gtid-  kdim-  tile_size-  num_groups-  group_size-  privstms-  red_comm-  red_lam-  map_lam-  num_whole_tiles-  accs-  w-  arrs_and_perms = do-    -- The number of residual elements that are not covered by-    -- the whole tiles.-    residual_input <--      letSubExp "residual_input" $-        BasicOp $ BinOp (SRem Int64 Unsafe) w tile_size+processResidualTile1D gid gtid kdim tile_size num_groups group_size args = do+  -- The number of residual elements that are not covered by+  -- the whole tiles.+  residual_input <-+    letSubExp "residual_input" $+      BasicOp $ BinOp (SRem Int64 Unsafe) w tile_size -    letTupExp "acc_after_residual"-      =<< eIf-        (toExp $ pe64 residual_input .==. 0)-        (resultBodyM $ map Var accs)-        (nonemptyTile residual_input)-    where-      nonemptyTile residual_input = runBodyBinder $ do-        -- Collectively construct a tile.  Threads that are out-of-bounds-        -- provide a blank dummy value.-        full_tile <--          readTile1D-            tile_size-            gid-            gtid-            num_groups-            group_size-            TilePartial-            privstms-            num_whole_tiles-            arrs_and_perms-        tile <- forM full_tile $ \tile ->-          letExp "partial_tile" $-            BasicOp $-              Index-                tile-                [DimSlice (intConst Int64 0) residual_input (intConst Int64 1)]+  letTupExp "acc_after_residual"+    =<< eIf+      (toExp $ pe64 residual_input .==. 0)+      (resultBodyM $ map Var accs)+      (nonemptyTile residual_input)+  where+    red_comm = residualComm args+    map_lam = residualMapLam args+    red_lam = residualRedLam args+    privstms = residualPrivStms args+    inputs = residualInput args+    accs = residualAcc args+    num_whole_tiles = residualNumWholeTiles args+    w = residualInputSize args -        -- Now each thread performs a traversal of the tile and-        -- updates its accumulator.-        resultBody . map Var-          <$> processTile1D-            gid-            gtid-            kdim-            residual_input-            num_groups-            group_size-            privstms-            red_comm-            red_lam-            map_lam-            (zip tile $ repeat [0])-            accs+    nonemptyTile residual_input = runBodyBinder $ do+      -- Collectively construct a tile.  Threads that are out-of-bounds+      -- provide a blank dummy value.+      full_tiles <-+        readTile1D+          tile_size+          gid+          gtid+          num_groups+          group_size+          TilePartial+          privstms+          num_whole_tiles+          inputs +      let sliceTile (InputUntiled arr) =+            pure $ InputUntiled arr+          sliceTile (InputTiled perm tile) = do+            let slice =+                  DimSlice (intConst Int64 0) residual_input (intConst Int64 1)+            InputTiled perm+              <$> letExp "partial_tile" (BasicOp $ Index tile [slice])++      tiles <- mapM sliceTile full_tiles++      -- Now each thread performs a traversal of the tile and+      -- updates its accumulator.+      let tile_args =+            ProcessTileArgs privstms red_comm red_lam map_lam tiles accs num_whole_tiles+      resultBody . map Var+        <$> processTile1D gid gtid kdim residual_input num_groups group_size tile_args+ tiling1d :: [(VName, SubExp)] -> DoTiling VName SubExp tiling1d dims_on_top initial_lvl gtid kdim w = do   gid <- newVName "gid"@@ -941,17 +963,17 @@   M.Map VName Names ->   [VName] ->   VName ->-  Maybe [Int]+  Maybe InputArray invariantToOneOfTwoInnerDims branch_variant variance dims arr = do   j : i : _ <- Just $ reverse dims   let variant_to = M.findWithDefault mempty arr variance       branch_invariant = not $ nameIn j branch_variant || nameIn i branch_variant   if branch_invariant && i `nameIn` variant_to && not (j `nameIn` variant_to)-    then Just [0, 1]+    then Just $ InputTile [0, 1] arr     else       if branch_invariant && j `nameIn` variant_to && not (i `nameIn` variant_to)-        then Just [1, 0]-        else Nothing+        then Just $ InputTile [1, 0] arr+        else Just $ InputDontTile arr  segMap2D ::   String ->@@ -1001,14 +1023,15 @@   TileKind ->   PrivStms ->   SubExp ->-  [(VName, [Int])] ->-  Binder Kernels [VName]-readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size num_groups group_size kind privstms tile_id arrs_and_perms =-  segMap2D-    "full_tile"-    (SegThread num_groups group_size SegNoVirtFull)-    ResultNoSimplify-    (tile_size, tile_size)+  [InputArray] ->+  Binder Kernels [InputTile]+readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size num_groups group_size kind privstms tile_id inputs =+  fmap (inputsToTiles inputs)+    . segMap2D+      "full_tile"+      (SegThread num_groups group_size SegNoVirtFull)+      ResultNoSimplify+      (tile_size, tile_size)     $ \(ltid_x, ltid_y) -> do       i <-         letSubExp "i"@@ -1020,20 +1043,23 @@       reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y)       addPrivStms [DimFix $ Var ltid_x, DimFix $ Var ltid_y] privstms -      let (arrs, perms) = unzip arrs_and_perms-      arr_ts <- mapM lookupType arrs-      let tile_ts = map rowType arr_ts-          w = arraysSize 0 arr_ts+      let arrs_and_perms = tiledInputs inputs -      let readTileElem arr perm =+          readTileElem (arr, perm) =             -- No need for fullSlice because we are tiling only prims.-            letExp "tile_elem" $-              BasicOp $-                Index-                  arr-                  [DimFix $ last $ rearrangeShape perm [i, j]]-          readTileElemIfInBounds (tile_t, arr, perm) = do-            let idx = last $ rearrangeShape perm [i, j]+            letExp+              "tile_elem"+              ( BasicOp $+                  Index+                    arr+                    [DimFix $ last $ rearrangeShape perm [i, j]]+              )++          readTileElemIfInBounds (arr, perm) = do+            arr_t <- lookupType arr+            let tile_t = rowType arr_t+                w = arraySize 0 arr_t+                idx = last $ rearrangeShape perm [i, j]                 othercheck =                   last $                     rearrangeShape@@ -1049,10 +1075,19 @@       fmap (map Var) $         case kind of           TilePartial ->-            mapM (letExp "pre" <=< readTileElemIfInBounds) (zip3 tile_ts arrs perms)+            mapM (letExp "pre" <=< readTileElemIfInBounds) arrs_and_perms           TileFull ->-            zipWithM readTileElem arrs perms+            mapM readTileElem arrs_and_perms +findTileSize :: HasScope lore m => [InputTile] -> m SubExp+findTileSize tiles =+  case mapMaybe isTiled tiles of+    v : _ -> arraySize 0 <$> lookupType v+    [] -> pure $ intConst Int64 0+  where+    isTiled InputUntiled {} = Nothing+    isTiled (InputTiled _ tile) = Just tile+ processTile2D ::   (VName, VName) ->   (VName, VName) ->@@ -1060,64 +1095,55 @@   SubExp ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->-  PrivStms ->-  Commutativity ->-  Lambda Kernels ->-  Lambda Kernels ->-  [(VName, [Int])] ->-  [VName] ->+  ProcessTileArgs ->   Binder Kernels [VName]-processTile2D-  (gid_x, gid_y)-  (gtid_x, gtid_y)-  (kdim_x, kdim_y)-  tile_size-  num_groups-  group_size-  privstms-  red_comm-  red_lam-  map_lam-  tiles_and_perms-  accs = do-    -- Might be truncated in case of a partial tile.-    actual_tile_size <- arraysSize 0 <$> mapM (lookupType . fst) tiles_and_perms+processTile2D (gid_x, gid_y) (gtid_x, gtid_y) (kdim_x, kdim_y) tile_size num_groups group_size tile_args = do+  let privstms = processPrivStms tile_args+      red_comm = processComm tile_args+      red_lam = processRedLam tile_args+      map_lam = processMapLam tile_args+      tiles = processTiles tile_args+      accs = processAcc tile_args+      tile_id = processTileId tile_args -    segMap2D-      "acc"-      (SegThread num_groups group_size SegNoVirtFull)-      ResultPrivate-      (tile_size, tile_size)-      $ \(ltid_x, ltid_y) -> do-        reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y)+  -- Might be truncated in case of a partial tile.+  actual_tile_size <- findTileSize tiles -        addPrivStms [DimFix $ Var ltid_x, DimFix $ Var ltid_y] privstms+  segMap2D+    "acc"+    (SegThread num_groups group_size SegNoVirtFull)+    ResultPrivate+    (tile_size, tile_size)+    $ \(ltid_x, ltid_y) -> do+      reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y) -        -- We replace the neutral elements with the accumulators (this is-        -- OK because the parallel semantics are not used after this-        -- point).-        thread_accs <- forM accs $ \acc ->-          letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid_x, DimFix $ Var ltid_y]-        let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam+      addPrivStms [DimFix $ Var ltid_x, DimFix $ Var ltid_y] privstms -        tiles' <- forM tiles_and_perms $ \(tile, perm) -> do-          tile_t <- lookupType tile-          letExp "tile" $-            BasicOp $-              Index tile $-                sliceAt-                  tile_t-                  (head perm)-                  [DimFix $ Var $ head $ rearrangeShape perm [ltid_x, ltid_y]]+      -- We replace the neutral elements with the accumulators (this is+      -- OK because the parallel semantics are not used after this+      -- point).+      thread_accs <- forM accs $ \acc ->+        letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid_x, DimFix $ Var ltid_y]+      let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam -        fmap (map Var) $-          letTupExp "acc"-            =<< eIf-              ( toExp $ le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y-              )-              (eBody [pure $ Op $ OtherOp $ Screma actual_tile_size form' tiles'])-              (resultBodyM thread_accs)+          sliceTile (InputUntiled arr) =+            sliceUntiled arr tile_id tile_size actual_tile_size+          sliceTile (InputTiled perm tile) = do+            tile_t <- lookupType tile+            let idx = DimFix $ Var $ head $ rearrangeShape perm [ltid_x, ltid_y]+            letExp "tile" $+              BasicOp $ Index tile $ sliceAt tile_t (head perm) [idx] +      tiles' <- mapM sliceTile tiles++      fmap (map Var) $+        letTupExp "acc"+          =<< eIf+            ( toExp $ le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y+            )+            (eBody [pure $ Op $ OtherOp $ Screma actual_tile_size form' tiles'])+            (resultBodyM thread_accs)+ processResidualTile2D ::   (VName, VName) ->   (VName, VName) ->@@ -1125,14 +1151,7 @@   SubExp ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->-  PrivStms ->-  Commutativity ->-  Lambda Kernels ->-  Lambda Kernels ->-  SubExp ->-  [VName] ->-  SubExp ->-  [(VName, [Int])] ->+  ResidualTileArgs ->   Binder Kernels [VName] processResidualTile2D   gids@@ -1141,14 +1160,7 @@   tile_size   num_groups   group_size-  privstms-  red_comm-  red_lam-  map_lam-  num_whole_tiles-  accs-  w-  arrs_and_perms = do+  args = do     -- The number of residual elements that are not covered by     -- the whole tiles.     residual_input <-@@ -1161,6 +1173,15 @@         (resultBodyM $ map Var accs)         (nonemptyTile residual_input)     where+      privstms = residualPrivStms args+      red_comm = residualComm args+      red_lam = residualRedLam args+      map_lam = residualMapLam args+      accs = residualAcc args+      inputs = residualInput args+      num_whole_tiles = residualNumWholeTiles args+      w = residualInputSize args+       nonemptyTile residual_input = renameBody <=< runBodyBinder $ do         -- Collectively construct a tile.  Threads that are out-of-bounds         -- provide a blank dummy value.@@ -1175,17 +1196,20 @@             TilePartial             privstms             num_whole_tiles-            arrs_and_perms+            inputs -        tile <- forM full_tile $ \tile ->-          letExp "partial_tile" $-            BasicOp $-              Index-                tile-                [ DimSlice (intConst Int64 0) residual_input (intConst Int64 1),-                  DimSlice (intConst Int64 0) residual_input (intConst Int64 1)-                ]+        let slice =+              DimSlice (intConst Int64 0) residual_input (intConst Int64 1)+        tiles <- forM full_tile $ \case+          InputTiled perm tile' ->+            InputTiled perm+              <$> letExp "partial_tile" (BasicOp $ Index tile' [slice, slice])+          InputUntiled arr ->+            pure $ InputUntiled arr +        let tile_args =+              ProcessTileArgs privstms red_comm red_lam map_lam tiles accs num_whole_tiles+         -- Now each thread performs a traversal of the tile and         -- updates its accumulator.         resultBody . map Var@@ -1196,12 +1220,7 @@             tile_size             num_groups             group_size-            privstms-            red_comm-            red_lam-            map_lam-            (zip tile (map snd arrs_and_perms))-            accs+            tile_args  tiling2d :: [(VName, SubExp)] -> DoTiling (VName, VName) (SubExp, SubExp) tiling2d dims_on_top _initial_lvl (gtid_x, gtid_y) (kdim_x, kdim_y) w = do

@@ -9,7 +9,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer-import Data.List (foldl')+import Data.List (find, foldl') import qualified Data.Map.Strict as M import Data.Maybe import Futhark.Analysis.Rephrase@@ -157,11 +157,19 @@   let (kbody', kbody_allocs) =         extractKernelBodyAllocations lvl bound_outside bound_in_kernel kbody       (ops', ops_allocs) = unzip $ map (extractLambdaAllocations lvl bound_outside mempty) ops-      variantAlloc (_, Var v, _) = v `nameIn` bound_in_kernel+      variantAlloc (_, Var v, _) = not $ v `nameIn` bound_outside       variantAlloc _ = False       allocs = kbody_allocs <> mconcat ops_allocs       (variant_allocs, invariant_allocs) = M.partition variantAlloc allocs+      badVariant (_, Var v, _) = not $ v `nameIn` bound_in_kernel+      badVariant _ = False +  case find badVariant $ M.elems variant_allocs of+    Just v ->+      throwError $ "Cannot handle un-sliceable allocation size: " ++ pretty v+    Nothing ->+      return ()+   case lvl of     SegGroup {}       | not $ null variant_allocs ->@@ -175,11 +183,12 @@     return (alloc_stms, (ops'', kbody''))   where     bound_in_kernel =-      namesFromList $-        M.keys $-          scopeOfSegSpace space-            <> scopeOf (kernelBodyStms kbody)+      namesFromList (M.keys $ scopeOfSegSpace space)+        <> boundInKernelBody kbody +boundInKernelBody :: KernelBody KernelsMem -> Names+boundInKernelBody = namesFromList . M.keys . scopeOf . kernelBodyStms+ allocsForBody ::   Extraction ->   Extraction ->@@ -288,10 +297,11 @@     Extraction   ) extractGenericBodyAllocations lvl bound_outside bound_kernel get_stms set_stms body =-  let (stms, allocs) =+  let bound_kernel' = bound_kernel <> boundByStms (get_stms body)+      (stms, allocs) =         runWriter $           fmap catMaybes $-            mapM (extractStmAllocations lvl bound_outside bound_kernel) $+            mapM (extractStmAllocations lvl bound_outside bound_kernel') $               stmsToList $ get_stms body    in (set_stms (stmsFromList stms) body, allocs) 

@@ -870,7 +870,9 @@           -- Normally the permutation is for the output pattern, but           -- we can't really change that, so we change the result           -- order instead.-          let lam_res' = rearrangeShape perm $ bodyResult $ lambdaBody lam+          let lam_res' =+                rearrangeShape (rearrangeInverse perm) $+                  bodyResult $ lambdaBody lam               lam' = lam {lambdaBody = (lambdaBody lam) {bodyResult = lam_res'}}               map_nesting = MapNesting pat aux w $ zip (lambdaParams lam) arrs               nest' = pushInnerKernelNesting (pat, lam_res') map_nesting nest

@@ -323,6 +323,7 @@       isMap (stmExp stm)         && not ("sequential" `inAttrs` stmAuxAttrs (stmAux stm))     isMap Op {} = True+    isMap (DoLoop _ _ ForLoop {} body) = bodyContainsParallelism body     isMap _ = False  lambdaContainsParallelism :: Lambda SOACS -> Bool

@@ -284,7 +284,7 @@       | [hash, ref] <- T.words l,         ["refs", "tags", t] <- T.splitOn "/" ref,         "v" `T.isPrefixOf` t,-        Right v <- semver $ T.drop 1 t,+        Right v <- parseVersion $ T.drop 1 t,         _svMajor v `elem` versions = do         pinfo <-           ghglLookupCommit@@ -359,7 +359,7 @@         <> "/"         <> T.pack futharkPkg     mk_zip_dir r-      | Right _ <- semver r = repo <> "-v" <> r+      | Right _ <- parseVersion r = repo <> "-v" <> r       | otherwise = repo <> "-" <> r  -- | A package registry is a mapping from package paths to information

@@ -41,12 +41,13 @@ import Data.Either import Data.Foldable import Data.List (sortOn)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Traversable-import Data.Versions (SemVer (..), VUnit (..), prettySemVer, semver)+import Data.Versions (SemVer (..), VUnit (..), prettySemVer) import Data.Void import System.FilePath import qualified System.FilePath.Posix as Posix@@ -69,13 +70,13 @@ -- @hash@ (typically the Git commit ID).  This function detects such -- versions. isCommitVersion :: SemVer -> Maybe T.Text-isCommitVersion (SemVer 0 0 0 [_] [[Str s]]) = Just s+isCommitVersion (SemVer 0 0 0 [_] [Str s NE.:| []]) = Just s isCommitVersion _ = Nothing  -- | @commitVersion timestamp commit@ constructs a commit version. commitVersion :: T.Text -> T.Text -> SemVer commitVersion time commit =-  SemVer 0 0 0 [[Str time]] [[Str commit]]+  SemVer 0 0 0 [Str time NE.:| []] [Str commit NE.:| []]  -- | Unfortunately, Data.Versions has a buggy semver parser that -- collapses consecutive zeroes in the metadata field.  So, we define

@@ -9,7 +9,8 @@ -- note where you got it from (and make sure that the license is -- compatible). module Futhark.Util-  ( mapAccumLM,+  ( nubOrd,+    mapAccumLM,     maxinum,     chunk,     chunks,@@ -53,7 +54,8 @@ import qualified Data.ByteString as BS import Data.Char import Data.Either-import Data.List (foldl', genericDrop, genericSplitAt)+import Data.List (foldl', genericDrop, genericSplitAt, sort)+import qualified Data.List.NonEmpty as NE import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -67,6 +69,10 @@ import System.IO (hIsTerminalDevice, stdout) import System.IO.Unsafe import System.Process.ByteString++-- | Like 'nub', but without the quadratic runtime.+nubOrd :: Ord a => [a] -> [a]+nubOrd = map NE.head . NE.group . sort  -- | Like 'Data.Traversable.mapAccumL', but monadic. mapAccumLM ::

@@ -527,9 +527,12 @@ patternMatch env (PatternParens p _) v = patternMatch env p v patternMatch env (PatternAscription p _ _) v =   patternMatch env p v-patternMatch env (PatternLit e _ _) v = do-  v' <- lift $ eval env e-  if v == v'+patternMatch env (PatternLit l t _) v = do+  l' <- case l of+    PatLitInt x -> lift $ eval env $ IntLit x t mempty+    PatLitFloat x -> lift $ eval env $ FloatLit x t mempty+    PatLitPrim lv -> pure $ ValuePrim lv+  if v == l'     then pure env     else mzero patternMatch env (PatternConstr n _ ps _) (ValueSum _ n' vs)

@@ -796,14 +796,12 @@                  : CFieldPattern ',' CFieldPatterns1 { $1 : $3 }                  | CFieldPattern                    { [$1] } -CaseLiteral :: { (UncheckedExp, SrcLoc) }-             : PrimLit        { (Literal (fst $1) (snd $1), snd $1) }-             | charlit        { let L loc (CHARLIT x) = $1-                                in (IntLit (toInteger (ord x)) NoInfo loc, loc) }-             | intlit         { let L loc (INTLIT x) = $1 in (IntLit x NoInfo loc, loc) }-             | floatlit       { let L loc (FLOATLIT x) = $1 in (FloatLit x NoInfo loc, loc) }-             | stringlit      { let L loc (STRINGLIT s) = $1 in-                              (StringLit (encode s) loc, loc) }+CaseLiteral :: { (PatLit, SrcLoc) }+             : PrimLit  { (PatLitPrim (fst $1), snd $1) }+             | charlit  { let L loc (CHARLIT x) = $1+                          in (PatLitInt (toInteger (ord x)), loc) }+             | intlit   { let L loc (INTLIT x) = $1 in (PatLitInt x, loc) }+             | floatlit { let L loc (FLOATLIT x) = $1 in (PatLitFloat x, loc) }  LoopForm :: { LoopFormBase NoInfo Name } LoopForm : for VarId '<' Exp

@@ -373,6 +373,11 @@   ppr (While cond) =     text "while" <+> ppr cond +instance Pretty PatLit where+  ppr (PatLitInt x) = ppr x+  ppr (PatLitFloat f) = ppr f+  ppr (PatLitPrim v) = ppr v+ instance (Eq vn, IsName vn, Annot f) => Pretty (PatternBase f vn) where   ppr (PatternAscription p t _) = ppr p <> colon <+> align (ppr t)   ppr (PatternParens p _) = parens $ ppr p

@@ -56,6 +56,7 @@     FieldBase (..),     CaseBase (..),     LoopFormBase (..),+    PatLit (..),     PatternBase (..),      -- * Module language@@ -894,6 +895,13 @@  deriving instance Ord (LoopFormBase NoInfo VName) +-- | A literal in a pattern.+data PatLit+  = PatLitInt Integer+  | PatLitFloat Double+  | PatLitPrim PrimValue+  deriving (Eq, Ord, Show)+ -- | A pattern as used most places where variables are bound (function -- parameters, @let@ expressions, etc). data PatternBase f vn@@ -903,7 +911,7 @@   | Id vn (f PatternType) SrcLoc   | Wildcard (f PatternType) SrcLoc -- Nothing, i.e. underscore.   | PatternAscription (PatternBase f vn) (TypeDeclBase f vn) SrcLoc-  | PatternLit (ExpBase f vn) (f PatternType) SrcLoc+  | PatternLit PatLit (f PatternType) SrcLoc   | PatternConstr Name (f PatternType) [PatternBase f vn] SrcLoc  deriving instance Showable f vn => Show (PatternBase f vn)

@@ -337,8 +337,8 @@     PatternAscription <$> astMap tv pat <*> astMap tv t <*> pure loc   astMap tv (Wildcard (Info t) loc) =     Wildcard <$> (Info <$> mapOnPatternType tv t) <*> pure loc-  astMap tv (PatternLit e (Info t) loc) =-    PatternLit <$> astMap tv e <*> (Info <$> mapOnPatternType tv t) <*> pure loc+  astMap tv (PatternLit v (Info t) loc) =+    PatternLit v <$> (Info <$> mapOnPatternType tv t) <*> pure loc   astMap tv (PatternConstr n (Info t) ps loc) =     PatternConstr n <$> (Info <$> mapOnPatternType tv t) <*> mapM (astMap tv) ps <*> pure loc @@ -393,7 +393,7 @@ barePat (Wildcard _ loc) = Wildcard NoInfo loc barePat (PatternAscription pat (TypeDecl t _) loc) =   PatternAscription (barePat pat) (TypeDecl t NoInfo) loc-barePat (PatternLit e _ loc) = PatternLit (bareExp e) NoInfo loc+barePat (PatternLit v _ loc) = PatternLit v NoInfo loc barePat (PatternConstr c _ ps loc) = PatternConstr c NoInfo (map barePat ps) loc  bareDimIndex :: DimIndexBase Info VName -> DimIndexBase NoInfo VName

@@ -20,6 +20,7 @@  import Control.Monad.Except import Control.Monad.Writer hiding (Sum)+import Data.Bifunctor (second) import Data.Char (isAlpha, isAlphaNum) import Data.Either import Data.List (isPrefixOf)@@ -49,7 +50,7 @@   VNameSource ->   ImportName ->   UncheckedProg ->-  Either TypeError (FileModule, Warnings, VNameSource)+  (Warnings, Either TypeError (FileModule, VNameSource)) checkProg files src name prog =   runTypeM initialEnv files' name src $ checkProgM prog   where@@ -65,10 +66,9 @@   VNameSource ->   Env ->   UncheckedExp ->-  Either TypeError ([TypeParam], Exp)-checkExp files src env e = do-  (e', _, _) <- runTypeM env files' (mkInitialImport "") src $ checkOneExp e-  return e'+  (Warnings, Either TypeError ([TypeParam], Exp))+checkExp files src env e =+  second (fmap fst) $ runTypeM env files' (mkInitialImport "") src $ checkOneExp e   where     files' = M.map fileEnv $ M.fromList files @@ -82,13 +82,15 @@   Env ->   ImportName ->   UncheckedDec ->-  Either TypeError (Env, Dec, VNameSource)-checkDec files src env name d = do-  ((env', d'), _, src') <- runTypeM env files' name src $ do-    (_, env', d') <- checkOneDec d-    return (env' <> env, d')-  return (env', d', src')+  (Warnings, Either TypeError (Env, Dec, VNameSource))+checkDec files src env name d =+  second (fmap massage) $+    runTypeM env files' name src $ do+      (_, env', d') <- checkOneDec d+      return (env' <> env, d')   where+    massage ((env', d'), src') =+      (env', d', src')     files' = M.map fileEnv $ M.fromList files  -- | Type check a single module expression containing no type information,@@ -100,10 +102,9 @@   VNameSource ->   Env ->   ModExpBase NoInfo Name ->-  Either TypeError (MTy, ModExpBase Info VName)-checkModExp files src env me = do-  (x, _, _) <- runTypeM env files' (mkInitialImport "") src $ checkOneModExp me-  return x+  (Warnings, Either TypeError (MTy, ModExpBase Info VName))+checkModExp files src env me =+  second (fmap fst) $ runTypeM env files' (mkInitialImport "") src $ checkOneModExp me   where     files' = M.map fileEnv $ M.fromList files @@ -298,7 +299,7 @@       (lookupType loc qn >> warnAbout qn)         `catchError` \_ -> return ()     warnAbout qn =-      warn loc $ "Inclusion shadows type " ++ quote (pretty qn) ++ "."+      warn loc $ "Inclusion shadows type" <+> pquote (ppr qn) <+> "."  checkSigExp :: SigExpBase NoInfo Name -> TypeM (MTy, SigExpBase Info VName) checkSigExp (SigParens e loc) = do@@ -615,16 +616,14 @@         typeError loc mempty "Entry point functions must not be size-polymorphic in their return type."       | p : _ <- filter nastyParameter params' ->         warn loc $-          pretty $-            "Entry point parameter\n"-              </> indent 2 (ppr p)-              </> "\nwill have an opaque type, so the entry point will likely not be callable."+          "Entry point parameter\n"+            </> indent 2 (ppr p)+            </> "\nwill have an opaque type, so the entry point will likely not be callable."       | nastyReturnType maybe_tdecl' rettype ->         warn loc $-          pretty $-            "Entry point return type\n"-              </> indent 2 (ppr rettype)-              </> "\nwill have an opaque type, so the result will likely not be usable."+          "Entry point return type\n"+            </> indent 2 (ppr rettype)+            </> "\nwill have an opaque type, so the result will likely not be usable."     _ -> return ()    let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt

@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Checking for missing cases in a match expression.  Based on+-- "Warnings for pattern matching" by Luc Maranget.  We only detect+-- inexhaustiveness here - ideally, we would also like to check for+-- redundant cases.+module Language.Futhark.TypeChecker.Match+  ( unmatched,+    Match,+  )+where++import qualified Data.Map.Strict as M+import Data.Maybe+import Futhark.Util (maybeHead, nubOrd)+import Futhark.Util.Pretty hiding (bool, group, space)+import Language.Futhark hiding (ExpBase (Constr), unscopeType)++data Constr+  = Constr Name+  | ConstrTuple+  | ConstrRecord [Name]+  | -- | Treated as 0-ary.+    ConstrLit PatLit+  deriving (Eq, Ord, Show)++-- | A representation of the essentials of a pattern.+data Match+  = MatchWild StructType+  | MatchConstr Constr [Match] StructType+  deriving (Eq, Ord, Show)++matchType :: Match -> StructType+matchType (MatchWild t) = t+matchType (MatchConstr _ _ t) = t++pprMatch :: Int -> Match -> Doc+pprMatch _ MatchWild {} = "_"+pprMatch _ (MatchConstr (ConstrLit l) _ _) = ppr l+pprMatch p (MatchConstr (Constr c) ps _) =+  parensIf (not (null ps) && p >= 10) $+    "#" <> ppr c <> mconcat (map ((" " <>) . pprMatch 10) ps)+pprMatch _ (MatchConstr ConstrTuple ps _) =+  parens $ commasep $ map (pprMatch (-1)) ps+pprMatch _ (MatchConstr (ConstrRecord fs) ps _) =+  braces $ commasep $ zipWith ppField fs ps+  where+    ppField name t = text (nameToString name) <> equals <> pprMatch (-1) t++instance Pretty Match where+  ppr = pprMatch (-1)++patternToMatch :: Pattern -> Match+patternToMatch (Id _ (Info t) _) = MatchWild $ toStruct t+patternToMatch (Wildcard (Info t) _) = MatchWild $ toStruct t+patternToMatch (PatternParens p _) = patternToMatch p+patternToMatch (PatternAscription p _ _) = patternToMatch p+patternToMatch (PatternLit l (Info t) _) =+  MatchConstr (ConstrLit l) [] $ toStruct t+patternToMatch p@(TuplePattern ps _) =+  MatchConstr ConstrTuple (map patternToMatch ps) $+    patternStructType p+patternToMatch p@(RecordPattern fs _) =+  MatchConstr (ConstrRecord fnames) (map patternToMatch ps) $+    patternStructType p+  where+    (fnames, ps) = unzip $ sortFields $ M.fromList fs+patternToMatch (PatternConstr c (Info t) args _) =+  MatchConstr (Constr c) (map patternToMatch args) $ toStruct t++isConstr :: Match -> Maybe Name+isConstr (MatchConstr (Constr c) _ _) = Just c+isConstr _ = Nothing++complete :: [Match] -> Bool+complete xs+  | Just x <- maybeHead xs,+    Scalar (Sum all_cs) <- matchType x,+    Just xs_cs <- mapM isConstr xs =+    all (`elem` xs_cs) (M.keys all_cs)+  | otherwise =+    (any (isBool True) xs && any (isBool False) xs)+      || all isRecord xs+      || all isTuple xs+  where+    isBool b1 (MatchConstr (ConstrLit (PatLitPrim (BoolValue b2))) _ _) = b1 == b2+    isBool _ _ = False+    isRecord (MatchConstr ConstrRecord {} _ _) = True+    isRecord _ = False+    isTuple (MatchConstr ConstrTuple _ _) = True+    isTuple _ = False++specialise :: [StructType] -> Match -> [[Match]] -> [[Match]]+specialise ats c1 = go+  where+    go ((c2 : row) : ps)+      | Just args <- match c1 c2 =+        (args ++ row) : go ps+      | otherwise =+        go ps+    go _ = []++    match (MatchConstr c1' _ _) (MatchConstr c2' args _)+      | c1' == c2' =+        Just args+      | otherwise =+        Nothing+    match _ MatchWild {} =+      Just $ map MatchWild ats+    match _ _ =+      Nothing++defaultMat :: [[Match]] -> [[Match]]+defaultMat = mapMaybe onRow+  where+    onRow (MatchConstr {} : _) = Nothing+    onRow (MatchWild {} : ps) = Just ps+    onRow [] = Nothing -- Should not happen.++findUnmatched :: [[Match]] -> Int -> [[Match]]+findUnmatched pmat n+  | ((p : _) : _) <- pmat,+    Just heads <- mapM maybeHead pmat =+    if complete heads+      then completeCase heads+      else incompleteCase (matchType p) heads+  where+    completeCase cs = do+      c <- cs+      let ats = case c of+            MatchConstr _ args _ -> map matchType args+            MatchWild _ -> []+          a_k = length ats+          pmat' = specialise ats c pmat+      u <- findUnmatched pmat' (a_k + n - 1)+      pure $ case c of+        MatchConstr c' _ t ->+          let (r, p) = splitAt a_k u+           in MatchConstr c' r t : p+        MatchWild t ->+          MatchWild t : u++    incompleteCase pt cs = do+      u <- findUnmatched (defaultMat pmat) (n - 1)+      if null cs+        then return $ MatchWild pt : u+        else case pt of+          Scalar (Sum all_cs) -> do+            -- Figure out which constructors are missing.+            let sigma = mapMaybe isConstr cs+                notCovered (k, _) = k `notElem` sigma+            (cname, ts) <- filter notCovered $ M.toList all_cs+            pure $ MatchConstr (Constr cname) (map MatchWild ts) pt : u+          _ ->+            -- This is where we could have enumerated missing match+            -- values (e.g. for booleans), rather than just emitting a+            -- wildcard.+            pure $ MatchWild pt : u++-- If we get here, then the number of columns must be zero.+findUnmatched [] _ = [[]]+findUnmatched _ _ = []++{-# NOINLINE unmatched #-}+unmatched :: [Pattern] -> [Match]+unmatched orig_ps =+  -- The algorithm may find duplicate example, which we filter away+  -- here.+  nubOrd $+    mapMaybe maybeHead $+      findUnmatched (map ((: []) . patternToMatch) orig_ps) 1

@@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TupleSections #-}@@ -48,7 +50,8 @@ where  import Control.Monad.Except-import Control.Monad.RWS.Strict hiding (Sum)+import Control.Monad.Reader+import Control.Monad.State.Strict import Data.Either import Data.List (find, isPrefixOf) import qualified Data.Map.Strict as M@@ -130,14 +133,20 @@     contextImportName :: ImportName   } +data TypeState = TypeState+  { stateNameSource :: VNameSource,+    stateWarnings :: Warnings+  }+ -- | The type checker runs in this monad. newtype TypeM a   = TypeM-      ( RWST-          Context -- Reader-          Warnings -- Writer-          VNameSource -- State-          (Except TypeError) -- Inner monad+      ( ReaderT+          Context+          ( StateT+              TypeState+              (Except (Warnings, TypeError))+          )           a       )   deriving@@ -145,11 +154,21 @@       Functor,       Applicative,       MonadReader Context,-      MonadWriter Warnings,-      MonadState VNameSource,-      MonadError TypeError+      MonadState TypeState     ) +instance MonadError TypeError TypeM where+  throwError e = TypeM $ do+    ws <- gets stateWarnings+    throwError (ws, e)++  catchError (TypeM m) f =+    TypeM $ m `catchError` f'+    where+      f' (_, e) =+        let TypeM m' = f e+         in m'+ -- | Run a 'TypeM' computation. runTypeM ::   Env ->@@ -157,10 +176,13 @@   ImportName ->   VNameSource ->   TypeM a ->-  Either TypeError (a, Warnings, VNameSource)+  (Warnings, Either TypeError (a, VNameSource)) runTypeM env imports fpath src (TypeM m) = do-  (x, src', ws) <- runExcept $ runRWST m (Context env imports fpath) src-  return (x, ws, src')+  let ctx = Context env imports fpath+      s = TypeState src mempty+  case runExcept $ runStateT (runReaderT m ctx) s of+    Left (ws, e) -> (ws, Left e)+    Right (x, TypeState src' ws) -> (ws, Right (x, src'))  -- | Retrieve the current 'Env'. askEnv :: TypeM Env@@ -202,7 +224,7 @@ -- internal interface is because we use distinct monads for checking -- expressions and declarations. class Monad m => MonadTypeChecker m where-  warn :: Located loc => loc -> String -> m ()+  warn :: Located loc => loc -> Doc -> m ()    newName :: VName -> m VName   newID :: Name -> m VName@@ -241,13 +263,17 @@   bindNameMap mapping body  instance MonadTypeChecker TypeM where-  warn loc problem = tell $ singleWarning (srclocOf loc) problem+  warn loc problem =+    modify $ \s ->+      s+        { stateWarnings = stateWarnings s <> singleWarning (srclocOf loc) problem+        } -  newName s = do-    src <- get-    let (s', src') = Futhark.FreshNames.newName src s-    put src'-    return s'+  newName v = do+    s <- get+    let (v', src') = Futhark.FreshNames.newName (stateNameSource s) v+    put $ s {stateNameSource = src'}+    return v'    newID s = newName $ VName s 0 

@@ -27,7 +27,7 @@ import Data.Bifunctor import Data.Char (isAscii) import Data.Either-import Data.List (find, foldl', group, isPrefixOf, nub, sort, transpose, (\\))+import Data.List (find, foldl', isPrefixOf, nub, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Maybe@@ -37,6 +37,7 @@ import Language.Futhark hiding (unscopeType) import Language.Futhark.Semantic (includeToString) import Language.Futhark.Traversals+import Language.Futhark.TypeChecker.Match import Language.Futhark.TypeChecker.Monad hiding (BoundV) import qualified Language.Futhark.TypeChecker.Monad as TypeM import Language.Futhark.TypeChecker.Types hiding (checkTypeDecl)@@ -692,12 +693,14 @@     "Variable" <+> pprName name <+> "previously consumed at"       <+> text (locStrRel loc2 loc1) <> "." -badLetWithValue :: SrcLoc -> TermTypeM a-badLetWithValue loc =-  typeError-    loc-    mempty-    "New value for elements in let-with shares data with source array.  This is illegal, as it prevents in-place modification."+badLetWithValue :: (Pretty arr, Pretty src) => arr -> src -> SrcLoc -> TermTypeM a+badLetWithValue arre vale loc =+  typeError loc mempty $+    "Source array for in-place update"+      </> indent 2 (ppr arre)+      </> "might alias update value"+      </> indent 2 (ppr vale)+      </> "Hint: use" <+> pquote "copy" <+> "to remove aliases from the value."  returnAliased :: Name -> Name -> SrcLoc -> TermTypeM () returnAliased fname name loc =@@ -750,6 +753,20 @@   = NoneInferred   | Ascribed PatternType +-- All this complexity is just so we can handle un-suffixed numeric+-- literals in patterns.+patLitMkType :: PatLit -> SrcLoc -> TermTypeM StructType+patLitMkType (PatLitInt _) loc = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t+  return t+patLitMkType (PatLitFloat _) loc = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyFloatType (mkUsage loc "float literal") t+  return t+patLitMkType (PatLitPrim v) _ =+  pure $ Scalar $ Prim $ primValueType v+ checkPattern' ::   UncheckedPattern ->   InferredType ->@@ -838,15 +855,13 @@         <*> pure loc   where     unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing-checkPattern' (PatternLit e NoInfo loc) (Ascribed t) = do-  e' <- checkExp e-  t' <- expTypeFully e'-  unify (mkUsage loc "matching against literal") (toStruct t') (toStruct t)-  return $ PatternLit e' (Info t') loc-checkPattern' (PatternLit e NoInfo loc) NoneInferred = do-  e' <- checkExp e-  t' <- expTypeFully e'-  return $ PatternLit e' (Info t') loc+checkPattern' (PatternLit l NoInfo loc) (Ascribed t) = do+  t' <- patLitMkType l loc+  unify (mkUsage loc "matching against literal") t' (toStruct t)+  return $ PatternLit l (Info (fromStruct t')) loc+checkPattern' (PatternLit l NoInfo loc) NoneInferred = do+  t' <- patLitMkType l loc+  return $ PatternLit l (Info (fromStruct t')) loc checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))   | Just ts <- M.lookup n cs = do     ps' <- zipWithM checkPattern' ps $ map Ascribed ts@@ -1518,7 +1533,7 @@     sequentially (unifies "type of target array" (toStruct elemt) =<< checkExp ve) $ \ve' _ -> do       ve_t <- expTypeFully ve'       when (AliasBound (identName src') `S.member` aliases ve_t) $-        badLetWithValue loc+        badLetWithValue src ve loc        bindingIdent dest (src_t `setAliases` S.empty) $ \dest' -> do         body' <- consuming src' $ checkExp body@@ -1542,7 +1557,7 @@        let src_als = aliases src_t       ve_t <- expTypeFully ve'-      unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue loc+      unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue src ve loc        consume loc src_als       return $ Update src' idxes' ve' loc@@ -2069,7 +2084,7 @@ -- | An unmatched pattern. Used in in the generation of -- unmatched pattern warnings by the type checker. data Unmatched p-  = UnmatchedNum p [ExpBase Info VName]+  = UnmatchedNum p [PatLit]   | UnmatchedBool p   | UnmatchedConstr p   | Unmatched p@@ -2093,43 +2108,12 @@       ppr' (PatternLit e _ _) = ppr e       ppr' (PatternConstr n _ ps _) = "#" <> ppr n <+> sep (map ppr' ps) -unpackPat :: Pattern -> [Maybe Pattern]-unpackPat Wildcard {} = [Nothing]-unpackPat (PatternParens p _) = unpackPat p-unpackPat Id {} = [Nothing]-unpackPat (TuplePattern ps _) = Just <$> ps-unpackPat (RecordPattern fs _) = Just . snd <$> sortFields (M.fromList fs)-unpackPat (PatternAscription p _ _) = unpackPat p-unpackPat p@PatternLit {} = [Just p]-unpackPat p@PatternConstr {} = [Just p]--wildPattern :: Pattern -> Int -> Unmatched Pattern -> Unmatched Pattern-wildPattern (TuplePattern ps loc) pos um = wildTuple <$> um-  where-    wildTuple p = TuplePattern (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc-    ps' = map wildOut ps-    wildOut p = Wildcard (Info (patternType p)) (srclocOf p)-wildPattern (RecordPattern fs loc) pos um = wildRecord <$> um-  where-    wildRecord p =-      RecordPattern (take (pos - 1) fs' ++ [(fst (fs !! (pos - 1)), p)] ++ drop pos fs') loc-    fs' = map wildOut fs-    wildOut (f, p) = (f, Wildcard (Info (patternType p)) (srclocOf p))-wildPattern (PatternAscription p _ _) pos um = wildPattern p pos um-wildPattern (PatternParens p _) pos um = wildPattern p pos um-wildPattern (PatternConstr n t ps loc) pos um = wildConstr <$> um-  where-    wildConstr p = PatternConstr n t (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc-    ps' = map wildOut ps-    wildOut p = Wildcard (Info (patternType p)) (srclocOf p)-wildPattern _ _ um = um- checkUnmatched :: Exp -> TermTypeM () checkUnmatched e = void $ checkUnmatched' e >> astMap tv e   where     checkUnmatched' (Match _ cs _ loc) =       let ps = fmap (\(CasePat p _ _) -> p) cs-       in case unmatched id $ NE.toList ps of+       in case unmatched $ NE.toList ps of             [] -> return ()             ps' ->               typeError loc mempty $@@ -2146,134 +2130,6 @@           mapOnPatternType = pure         } --- | A data type for constructor patterns.  This is used to make the--- code for detecting unmatched constructors cleaner, by separating--- the constructor-pattern cases from other cases.-data ConstrPat = ConstrPat-  { constrName :: Name,-    constrType :: PatternType,-    constrPayload :: [Pattern],-    constrSrcLoc :: SrcLoc-  }---- Be aware of these fishy equality instances!--instance Eq ConstrPat where-  ConstrPat c1 _ _ _ == ConstrPat c2 _ _ _ = c1 == c2--instance Ord ConstrPat where-  ConstrPat c1 _ _ _ `compare` ConstrPat c2 _ _ _ = c1 `compare` c2--unmatched :: (Unmatched Pattern -> Unmatched Pattern) -> [Pattern] -> [Unmatched Pattern]-unmatched hole orig_ps-  | p : _ <- orig_ps,-    sameStructure labeledCols = do-    (i, cols) <- labeledCols-    let hole' = if isConstr p then hole else hole . wildPattern p i-    case sequence cols of-      Nothing -> []-      Just cs-        | all isPatternLit cs -> map hole' $ localUnmatched cs-        | otherwise -> unmatched hole' cs-  | otherwise = []-  where-    labeledCols = zip [1 ..] $ transpose $ map unpackPat orig_ps--    localUnmatched :: [Pattern] -> [Unmatched Pattern]-    localUnmatched [] = []-    localUnmatched ps'@(p' : _) =-      case patternType p' of-        Scalar (Sum cs'') ->-          -- We now know that we are matching a sum type, and thus-          -- that all patterns ps' are constructors (checked by-          -- 'all isPatternLit' before this function is called).-          let constrs = M.keys cs''-              matched = mapMaybe constr ps'-              unmatched' =-                map (UnmatchedConstr . buildConstr cs'') $-                  constrs \\ map constrName matched-           in case unmatched' of-                [] ->-                  let constrGroups = group (sort matched)-                      removedConstrs = mapMaybe stripConstrs constrGroups-                      transposed = (fmap . fmap) transpose removedConstrs-                      findUnmatched (pc, trans) = do-                        col <- trans-                        case col of-                          [] -> []-                          ((i, _) : _) -> unmatched (wilder i pc) (map snd col)-                      wilder i pc s = (`PatternParens` mempty) <$> wildPattern pc i s-                   in concatMap findUnmatched transposed-                _ -> unmatched'-        Scalar (Prim t) | not (any idOrWild ps') ->-          -- We now know that we are matching a sum type, and thus-          -- that all patterns ps' are literals (checked by 'all-          -- isPatternLit' before this function is called).-          case t of-            Bool ->-              let matched = nub $ mapMaybe (pExp >=> bool) $ filter isPatternLit ps'-               in map (UnmatchedBool . buildBool (Scalar (Prim t))) $ [True, False] \\ matched-            _ ->-              let matched = mapMaybe pExp $ filter isPatternLit ps'-               in [UnmatchedNum (buildId (Info $ Scalar $ Prim t) "p") matched]-        _ -> []--    isConstr PatternConstr {} = True-    isConstr (PatternParens p _) = isConstr p-    isConstr _ = False--    stripConstrs :: [ConstrPat] -> Maybe (Pattern, [[(Int, Pattern)]])-    stripConstrs (pc@ConstrPat {} : cs') = Just (unConstr pc, stripConstr pc : map stripConstr cs')-    stripConstrs [] = Nothing--    stripConstr :: ConstrPat -> [(Int, Pattern)]-    stripConstr (ConstrPat _ _ ps' _) = zip [1 ..] ps'--    sameStructure [] = True-    sameStructure (x : xs) = all (\y -> length y == length x') xs'-      where-        (x' : xs') = map snd (x : xs)--    pExp (PatternLit e' _ _) = Just e'-    pExp _ = Nothing--    constr (PatternConstr c (Info t) ps loc) = Just $ ConstrPat c t ps loc-    constr (PatternParens p _) = constr p-    constr (PatternAscription p' _ _) = constr p'-    constr _ = Nothing--    unConstr p =-      PatternConstr (constrName p) (Info $ constrType p) (constrPayload p) (constrSrcLoc p)--    isPatternLit PatternLit {} = True-    isPatternLit (PatternAscription p' _ _) = isPatternLit p'-    isPatternLit (PatternParens p' _) = isPatternLit p'-    isPatternLit PatternConstr {} = True-    isPatternLit _ = False--    idOrWild Id {} = True-    idOrWild Wildcard {} = True-    idOrWild (PatternAscription p' _ _) = idOrWild p'-    idOrWild (PatternParens p' _) = idOrWild p'-    idOrWild _ = False--    bool (Literal (BoolValue b) _) = Just b-    bool _ = Nothing--    buildConstr m c =-      let t = Scalar $ Sum m-          cs = m M.! c-          wildCS = map (\ct -> Wildcard (Info ct) mempty) cs-       in if null wildCS-            then PatternConstr c (Info t) [] mempty-            else PatternParens (PatternConstr c (Info t) wildCS mempty) mempty-    buildBool t b =-      PatternLit (Literal (BoolValue b) mempty) (Info (addSizes t)) mempty-    buildId t n =-      -- The VName tag here will never be used since the value-      -- exists exclusively for printing warnings.-      Id (VName (nameFromString n) (-1)) t mempty- checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident checkIdent (Ident name _ loc) = do   (QualName _ name', vt) <- lookupVar loc (qualName name)@@ -3255,7 +3111,7 @@ checkIfUsed occs v   | not $ identName v `S.member` allOccuring occs,     not $ "_" `isPrefixOf` prettyName (identName v) =-    warn (srclocOf v) $ "Unused variable " ++ quote (pretty $ baseName $ identName v) ++ "."+    warn (srclocOf v) $ "Unused variable" <+> pquote (pprName $ identName v) <+> "."   | otherwise =     return () 

@@ -180,7 +180,7 @@ checkTypeExp (TEUnique t loc) = do   (t', st, l) <- checkTypeExp t   unless (mayContainArray st) $-    warn loc $ "Declaring " <> quote (pretty st) <> " as unique has no effect."+    warn loc $ "Declaring" <+> pquote (ppr st) <+> "as unique has no effect."   return (TEUnique t' loc, st `setUniqueness` Unique, l)   where     mayContainArray (Scalar Prim {}) = False

@@ -5,21 +5,23 @@ -- 'Show'-instance produces a human-readable string. module Language.Futhark.Warnings   ( Warnings,+    anyWarnings,     singleWarning,     singleWarning',   ) where -import Data.List (intercalate, sortOn)+import Data.List (sortOn) import Data.Monoid import Futhark.Util.Console (inRed) import Futhark.Util.Loc+import Futhark.Util.Pretty import Language.Futhark.Core (locStr, prettyStacktrace) import Prelude  -- | The warnings produced by the compiler.  The 'Show' instance -- produces a human-readable description.-newtype Warnings = Warnings [(SrcLoc, [SrcLoc], String)] deriving (Eq)+newtype Warnings = Warnings [(SrcLoc, [SrcLoc], Doc)]  instance Semigroup Warnings where   Warnings ws1 <> Warnings ws2 = Warnings $ ws1 <> ws2@@ -27,30 +29,35 @@ instance Monoid Warnings where   mempty = Warnings mempty -instance Show Warnings where-  show (Warnings []) = ""-  show (Warnings ws) =-    intercalate "\n\n" ws' ++ "\n"+instance Pretty Warnings where+  ppr (Warnings []) = mempty+  ppr (Warnings ws) =+    stack $ punctuate line $ map onWarning $ sortOn (rep . wloc) ws     where-      ws' = map showWarning $ sortOn (rep . wloc) ws       wloc (x, _, _) = locOf x       rep NoLoc = ("", 0)       rep (Loc p _) = (posFile p, posCoff p)-      showWarning (loc, [], w) =-        inRed ("Warning at " ++ locStr loc ++ ":") ++ "\n"-          ++ intercalate "\n" (map ("  " <>) $ lines w)-      showWarning (loc, locs, w) =-        inRed-          ( "Warning at\n"-              ++ prettyStacktrace 0 (map locStr (loc : locs))+      onWarning (loc, [], w) =+        text (inRed ("Warning at " ++ locStr loc ++ ":"))+          </> indent 2 w+      onWarning (loc, locs, w) =+        text+          ( inRed+              ( "Warning at\n"+                  ++ prettyStacktrace 0 (map locStr (loc : locs))+              )           )-          ++ intercalate "\n" (map ("  " <>) $ lines w)+          </> indent 2 w +-- | True if there are any warnings in the set.+anyWarnings :: Warnings -> Bool+anyWarnings (Warnings ws) = not $ null ws+ -- | A single warning at the given location.-singleWarning :: SrcLoc -> String -> Warnings+singleWarning :: SrcLoc -> Doc -> Warnings singleWarning loc = singleWarning' loc []  -- | A single warning at the given location, but also with a stack -- trace (sort of) to the location.-singleWarning' :: SrcLoc -> [SrcLoc] -> String -> Warnings+singleWarning' :: SrcLoc -> [SrcLoc] -> Doc -> Warnings singleWarning' loc locs problem = Warnings [(loc, locs, problem)]

@@ -32,6 +32,7 @@ import Futhark.Util (maxinum) import Futhark.Util.Options import GHC.IO.Encoding (setLocaleEncoding)+import GHC.IO.Exception (IOErrorType (..), IOException (..)) import System.Environment import System.Exit import System.IO@@ -78,7 +79,14 @@ -- | Catch all IO exceptions and print a better error message if they -- happen. reportingIOErrors :: IO () -> IO ()-reportingIOErrors = flip catches [Handler onExit, Handler onICE, Handler onError]+reportingIOErrors =+  flip+    catches+    [ Handler onExit,+      Handler onICE,+      Handler onIOException,+      Handler onError+    ]   where     onExit :: ExitCode -> IO ()     onExit = throwIO@@ -88,10 +96,12 @@       T.hPutStrLn stderr "Known compiler limitation encountered.  Sorry."       T.hPutStrLn stderr "Revise your program or try a different Futhark compiler."       T.hPutStrLn stderr s+      exitWith $ ExitFailure 1     onICE (Error CompilerBug s) = do       T.hPutStrLn stderr "Internal compiler error."       T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues."       T.hPutStrLn stderr s+      exitWith $ ExitFailure 1      onError :: SomeException -> IO ()     onError e@@ -102,6 +112,12 @@         T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues"         T.hPutStrLn stderr $ T.pack $ show e         exitWith $ ExitFailure 1++    onIOException :: IOException -> IO ()+    onIOException e+      | ioe_type e == ResourceVanished =+        exitWith $ ExitFailure 1+      | otherwise = throw e  main :: IO () main = reportingIOErrors $ do