diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -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 ------------------ diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -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 diff --git a/docs/man/futhark-dataset.rst b/docs/man/futhark-dataset.rst --- a/docs/man/futhark-dataset.rst +++ b/docs/man/futhark-dataset.rst @@ -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 ======= diff --git a/docs/usage.rst b/docs/usage.rst --- a/docs/usage.rst +++ b/docs/usage.rst @@ -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 -------------------- diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: futhark -version: 0.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 diff --git a/rts/c/chaselev.h b/rts/c/chaselev.h --- a/rts/c/chaselev.h +++ b/rts/c/chaselev.h @@ -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 diff --git a/rts/c/multicore_defs.h b/rts/c/multicore_defs.h deleted file mode 100644 --- a/rts/c/multicore_defs.h +++ /dev/null @@ -1,108 +0,0 @@ -// start of multicore_defs.h - -#ifndef MULTICORE_DEFS -#define MULTICORE_DEFS - -#include - -/* #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 -#elif defined(__APPLE__) -#include -// For getting cpu usage of threads -#include -#include -#elif defined(__linux__) -#include -#include -#include -#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 diff --git a/rts/c/multicore_util.h b/rts/c/multicore_util.h deleted file mode 100644 --- a/rts/c/multicore_util.h +++ /dev/null @@ -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 diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.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; diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -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 + +#if defined(_WIN32) +#include +#elif defined(__APPLE__) +#include +// For getting cpu usage of threads +#include +#include +#elif defined(__linux__) +#include +#include +#include +#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 diff --git a/rts/c/scheduler_common.h b/rts/c/scheduler_common.h deleted file mode 100644 --- a/rts/c/scheduler_common.h +++ /dev/null @@ -1,244 +0,0 @@ -// start of scheduler_common.h - -#ifndef _SCHEDULER_COMMON_H_ -#define _SCHEDULER_COMMON_H_ - -#include - -/* 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 diff --git a/rts/c/scheduler_tune.h b/rts/c/scheduler_tune.h deleted file mode 100644 --- a/rts/c/scheduler_tune.h +++ /dev/null @@ -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; -} diff --git a/rts/c/subtask_queue.h b/rts/c/subtask_queue.h deleted file mode 100644 --- a/rts/c/subtask_queue.h +++ /dev/null @@ -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 diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.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); } } diff --git a/src/Futhark/CLI/Check.hs b/src/Futhark/CLI/Check.hs --- a/src/Futhark/CLI/Check.hs +++ b/src/Futhark/CLI/Check.hs @@ -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 diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -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 diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs --- a/src/Futhark/CLI/Run.hs +++ b/src/Futhark/CLI/Run.hs @@ -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) diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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; }|] ) diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -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; }|] ) diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -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 ") $esc:("#include ") $esc:("#include ") +$esc:("#include ") $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 diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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) = diff --git a/src/Futhark/CodeGen/Backends/MulticoreC.hs b/src/Futhark/CodeGen/Backends/MulticoreC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreC.hs @@ -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; diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore.hs b/src/Futhark/CodeGen/ImpGen/Multicore.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs @@ -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 diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -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 diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -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, diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -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 diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -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 diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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. diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -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)] diff --git a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs --- a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +++ b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs @@ -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 = diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -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 diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -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) diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -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 diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -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 diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs --- a/src/Futhark/Pkg/Types.hs +++ b/src/Futhark/Pkg/Types.hs @@ -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 diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -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 :: diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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) diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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 diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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 diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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) diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/TypeChecker/Match.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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 () diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -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 diff --git a/src/Language/Futhark/Warnings.hs b/src/Language/Futhark/Warnings.hs --- a/src/Language/Futhark/Warnings.hs +++ b/src/Language/Futhark/Warnings.hs @@ -5,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)] diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -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