Dear all, as requested,
See attached patch 8 of 13
Best Regards,
Jerry
commit 290f3b399ec3cb5991e28edf30cc55ba3a39c176
Author: Andre Vehreschild <[email protected]>
Date: Wed Aug 6 15:36:54 2025 +0200
Fortran: Fix caf_shmem syncing on Windows.
Cygwin's libc's pthread implementation does not support setting
pshared on mutexes and condition variables. Therefore Windows
synchronisation primitives needed to be used directly.
On MSYS2/UCRT64 fork and mmap are not available and Windows core
functionality needs to be used.
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_init): Cleanup thread helper after
use.
(_gfortran_caf_finalize): Same.
(_gfortran_caf_register): Handle lock_t correctly on Windows.
(GEN_OP): Prevent warnings on non-initialized.
(_gfortran_caf_lock): Handle lock_t correctly on Windows.
(_gfortran_caf_unlock): Same.
(_gfortran_caf_random_init): Fix formatting.
(_gfortran_caf_form_team): Add more images to counter_barrier.
* caf/shmem/alloc.c: Use routines from thread_support.
* caf/shmem/allocator.c (allocator_lock): Same.
(allocator_unlock): Same.
* caf/shmem/allocator.h: Same.
* caf/shmem/collective_subroutine.c (get_collsub_buf): Same.
* caf/shmem/collective_subroutine.h: Same.
* caf/shmem/counter_barrier.c (lock_counter_barrier): Same.
(unlock_counter_barrier): Same.
(counter_barrier_init): Same.
(counter_barrier_wait): Same.
(change_internal_barrier_count): Same.
(counter_barrier_add): Same.
(counter_barrier_init_add): Only increase value w/o signaling.
(counter_barrier_get_count): Use routines from thread_support.
* caf/shmem/counter_barrier.h: Same.
(counter_barrier_init_add): New routine.
* caf/shmem/shared_memory.c: Use windows routines where
applicable.
(shared_memory_set_env): Same.
(shared_memory_get_master): Same.
(shared_memory_init): Same.
(shared_memory_cleanup): Same.
* caf/shmem/shared_memory.h: Use types from thread_support.
* caf/shmem/supervisor.c: Use windows routines where applicable.
(get_memory_size_from_envvar): Same.
(ensure_shmem_initialization): Same.
(supervisor_main_loop): Use windows process start on windows
without fork().
* caf/shmem/supervisor.h: Use types from thread_support.
* caf/shmem/sync.c (lock_table): Use routines from thread_support.
(unlock_table): Same.
(sync_init): Same.
(sync_init_supervisor): Same.
(sync_table): Same.
(lock_event): Same.
(unlock_event): Same.
(event_post): Same.
(event_wait): Same.
* caf/shmem/sync.h: Use types from thread_support.
* caf/shmem/teams_mgmt.c (update_teams_images): Use routines from
thread_support.
* caf/shmem/thread_support.c: Add synchronisation primitives for
windows.
(smax): Windows only: Max for size_t.
(get_handle): Windows only: Get the windows handle for a given
id or create a new one, if it does not exist.
(get_mutex): Windows only: Shortcut for getting a windows mutex
handle.
(get_condvar): Windows only: Same, but for condition variable.
(thread_support_init_supervisor): Windows only: Clear tracker of
allocated handle ids.
(caf_shmem_mutex_lock): Windows only: Implememtation of lock,
(caf_shmem_mutex_trylock): Windows only: trylock, and
(caf_shmem_mutex_unlock): Windows only: unlock for Windows.
(bm_is_set): Windows only: Check a bit is set in a mask.
(bm_clear_bit): Windows only: Clear a bit in a mask.
(bm_set_mask): Windows only: Set all bits in a mask.
(bm_is_none): Windows only: Check if all bits are cleared.
(caf_shmem_cond_wait): Windows only: Condition variable
implemenation fro wait,
(caf_shmem_cond_broadcast): Windows only: broadcast, and
(caf_shmem_cond_signal): Windows only: signal on Windows.
(caf_shmem_cond_update_count): Windows only: Need to know the
images participating in a condition variable.
(thread_support_cleanup): Windows only: Clean up the handles on
exit.
* caf/shmem/thread_support.h: Conditionally compile the types
as required for Windows and other OSes.
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index b8d92d657f5..266feab3e45 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -94,6 +94,8 @@ _gfortran_caf_init (int *argc, char ***argv)
if (supervisor_main_loop (argc, argv, &exit_code))
return;
+
+ thread_support_cleanup ();
shared_memory_cleanup (&local->sm);
/* Free pseudo tokens and memory to allow main process to survive caf_init.
@@ -107,6 +109,7 @@ _gfortran_caf_init (int *argc, char ***argv)
caf_static_list = tmp;
}
free (local);
+
exit (exit_code);
}
@@ -150,6 +153,8 @@ _gfortran_caf_finalize (void)
caf_teams_formed = NULL;
free (local);
+
+ thread_support_cleanup ();
}
int
@@ -267,19 +272,25 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
{
lock_t *addr;
bool created;
+ size_t alloc_size;
allocator_lock (&local->ai.alloc);
- /* Allocate enough space for the metadata infront of the lock
- array. */
- addr
- = alloc_get_memory_by_id_created (&local->ai, size * sizeof (lock_t),
- next_memid, &created);
+#if defined(WIN32) || defined(__CYGWIN__)
+ /* On Windows mutexes are not an object stored in the shmem but
+ identified by an id. */
+ alloc_size = size * caf_current_team->u.image_info->image_count.count;
+#else
+ alloc_size = size;
+#endif
+ addr = alloc_get_memory_by_id_created (&local->ai,
+ alloc_size * sizeof (lock_t),
+ next_memid, &created);
if (created)
{
/* Initialize the mutex only, when the memory was allocated for the
first time. */
- for (size_t c = 0; c < size; ++c)
+ for (size_t c = 0; c < alloc_size; ++c)
initialize_shared_errorcheck_mutex (&addr[c]);
}
size *= sizeof (lock_t);
@@ -852,6 +863,7 @@ typedef void *opr_t;
default: \
caf_runtime_error ("" #name \
" not available for type/kind combination"); \
+ opr = NULL; /* Prevent false warnings. */ \
} \
break; \
}
@@ -873,10 +885,12 @@ typedef void *opr_t;
default: \
caf_runtime_error ("" #name \
" not available for type/kind combination"); \
+ opr = NULL; /* Prevent false warning. */ \
} \
break; \
default: \
caf_runtime_error ("" #name " not available for type/kind combination"); \
+ opr = NULL; /* Prevent false warning. */ \
}
void
@@ -1473,17 +1487,23 @@ _gfortran_caf_event_query (caf_token_t token, size_t index, int image_index,
}
void
-_gfortran_caf_lock (caf_token_t token, size_t index,
- int image_index __attribute__ ((unused)),
+_gfortran_caf_lock (caf_token_t token, size_t index, int image_index,
int *acquired_lock, int *stat, char *errmsg,
size_t errmsg_len)
{
const char *msg = "Already locked";
- lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+#if defined(WIN32) || defined(__CYGWIN__)
+ const size_t lock_index
+ = image_index * caf_current_team->u.image_info->image_count.count + index;
+#else
+ const size_t lock_index = index;
+ (void) image_index; // Prevent unused warnings.
+#endif
+ lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index];
int res;
- res
- = acquired_lock ? pthread_mutex_trylock (lock) : pthread_mutex_lock (lock);
+ res = acquired_lock ? caf_shmem_mutex_trylock (lock)
+ : caf_shmem_mutex_lock (lock);
if (stat)
*stat = res == EBUSY ? GFC_STAT_LOCKED : 0;
@@ -1501,28 +1521,32 @@ _gfortran_caf_lock (caf_token_t token, size_t index,
{
if (errmsg_len > 0)
{
- size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
- : sizeof (msg);
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
- memset (&errmsg[len], ' ', errmsg_len-len);
+ memset (&errmsg[len], ' ', errmsg_len - len);
}
return;
}
_gfortran_caf_error_stop_str (msg, strlen (msg), false);
}
-
void
-_gfortran_caf_unlock (caf_token_t token, size_t index,
- int image_index __attribute__ ((unused)),
+_gfortran_caf_unlock (caf_token_t token, size_t index, int image_index,
int *stat, char *errmsg, size_t errmsg_len)
{
const char *msg = "Variable is not locked";
- lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+#if defined(WIN32) || defined(__CYGWIN__)
+ const size_t lock_index
+ = image_index * caf_current_team->u.image_info->image_count.count + index;
+#else
+ const size_t lock_index = index;
+ (void) image_index; // Prevent unused warnings.
+#endif
+ lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index];
int res;
- res = pthread_mutex_unlock (lock);
+ res = caf_shmem_mutex_unlock (lock);
if (res == 0)
{
@@ -1535,34 +1559,33 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
{
/* res == EPERM means that the lock is locked. Now figure, if by us by
trying to lock it or by other image, which fails. */
- res = pthread_mutex_trylock (lock);
+ res = caf_shmem_mutex_trylock (lock);
if (res == EBUSY)
*stat = GFC_STAT_LOCKED_OTHER_IMAGE;
else
{
*stat = GFC_STAT_UNLOCKED;
- pthread_mutex_unlock (lock);
+ caf_shmem_mutex_unlock (lock);
}
if (errmsg_len > 0)
{
- size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
- : sizeof (msg);
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
- memset (&errmsg[len], ' ', errmsg_len-len);
+ memset (&errmsg[len], ' ', errmsg_len - len);
}
return;
}
_gfortran_caf_error_stop_str (msg, strlen (msg), false);
}
-
/* Reference the libraries implementation. */
extern void _gfortran_random_seed_i4 (int32_t *size, gfc_array_i4 *put,
gfc_array_i4 *get);
-void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
+void
+_gfortran_caf_random_init (bool repeatable, bool image_distinct)
{
static struct
{
@@ -1720,8 +1743,8 @@ _gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,
++i)
t->u.image_info->image_map[i] = -1;
}
- counter_barrier_add (&t->u.image_info->image_count, 1);
- counter_barrier_add (&t->u.image_info->collsub.barrier, 1);
+ counter_barrier_init_add (&t->u.image_info->image_count, 1);
+ counter_barrier_init_add (&t->u.image_info->collsub.barrier, 1);
allocator_unlock (&local->ai.alloc);
if (new_index)
diff --git a/libgfortran/caf/shmem/alloc.c b/libgfortran/caf/shmem/alloc.c
index fecf97c03ff..ea250ac6922 100644
--- a/libgfortran/caf/shmem/alloc.c
+++ b/libgfortran/caf/shmem/alloc.c
@@ -30,9 +30,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "../caf_error.h"
#include "supervisor.h"
#include "shared_memory.h"
+#include "thread_support.h"
#include <assert.h>
-#include <pthread.h>
#include <string.h>
/* Worker's part to initialize the alloc interface. */
diff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c
index 3ea4d50e045..2a22abb2a80 100644
--- a/libgfortran/caf/shmem/allocator.c
+++ b/libgfortran/caf/shmem/allocator.c
@@ -133,11 +133,11 @@ allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size)
void
allocator_lock (allocator *a)
{
- pthread_mutex_lock (&a->s->lock);
+ caf_shmem_mutex_lock (&a->s->lock);
}
void
allocator_unlock (allocator *a)
{
- pthread_mutex_unlock (&a->s->lock);
+ caf_shmem_mutex_unlock (&a->s->lock);
}
diff --git a/libgfortran/caf/shmem/allocator.h b/libgfortran/caf/shmem/allocator.h
index 53b6abeeba1..0cf31ea837a 100644
--- a/libgfortran/caf/shmem/allocator.h
+++ b/libgfortran/caf/shmem/allocator.h
@@ -29,16 +29,16 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define ALLOCATOR_HDR
#include "shared_memory.h"
+#include "thread_support.h"
#include <stddef.h>
-#include <pthread.h>
/* The number of bits a void pointer has. */
#define VOIDP_BITS (__CHAR_BIT__ * sizeof (void *))
/* The shared memory part of the allocator. */
typedef struct {
- pthread_mutex_t lock;
+ caf_shmem_mutex lock;
shared_mem_ptr free_bucket_head[VOIDP_BITS];
} allocator_shared;
diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c
index 257a048d63d..d261b412a93 100644
--- a/libgfortran/caf/shmem/collective_subroutine.c
+++ b/libgfortran/caf/shmem/collective_subroutine.c
@@ -198,7 +198,7 @@ get_collsub_buf (size_t size)
{
void *ret;
- pthread_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
+ caf_shmem_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
/* curr_size is always at least sizeof(double), so we don't need to worry
about size == 0. */
if (size > caf_current_team->u.image_info->collsub.curr_size)
@@ -214,7 +214,7 @@ get_collsub_buf (size_t size)
ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,
&local->sm);
- pthread_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
+ caf_shmem_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
return ret;
}
diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h
index 8c37186c867..bdddab07a93 100644
--- a/libgfortran/caf/shmem/collective_subroutine.h
+++ b/libgfortran/caf/shmem/collective_subroutine.h
@@ -36,7 +36,7 @@ typedef struct collsub_shared
size_t curr_size;
shared_mem_ptr collsub_buf;
counter_barrier barrier;
- pthread_mutex_t mutex;
+ caf_shmem_mutex mutex;
} collsub_shared;
void collsub_init_supervisor (collsub_shared *, allocator *,
diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c
index f78ba7fe852..2cda2afb2ed 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -34,7 +34,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
static inline void
lock_counter_barrier (counter_barrier *b)
{
- pthread_mutex_lock (&b->mutex);
+ caf_shmem_mutex_lock (&b->mutex);
}
/* Unlock the associated counter of this barrier. */
@@ -42,15 +42,15 @@ lock_counter_barrier (counter_barrier *b)
static inline void
unlock_counter_barrier (counter_barrier *b)
{
- pthread_mutex_unlock (&b->mutex);
+ caf_shmem_mutex_unlock (&b->mutex);
}
void
counter_barrier_init (counter_barrier *b, int val)
{
- *b = (counter_barrier) {PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER,
- val, 0, val};
- initialize_shared_condition (&b->cond);
+ *b = (counter_barrier) {CAF_SHMEM_MUTEX_INITIALIZER,
+ CAF_SHMEM_COND_INITIALIZER, val, 0, val};
+ initialize_shared_condition (&b->cond, val);
initialize_shared_mutex (&b->mutex);
}
@@ -60,15 +60,14 @@ counter_barrier_wait (counter_barrier *b)
int wait_group_beginning;
lock_counter_barrier (b);
-
wait_group_beginning = b->curr_wait_group;
if ((--b->wait_count) <= 0)
- pthread_cond_broadcast (&b->cond);
+ caf_shmem_cond_broadcast (&b->cond);
else
{
while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
- pthread_cond_wait (&b->cond, &b->mutex);
+ caf_shmem_cond_wait (&b->cond, &b->mutex);
}
if (b->wait_count <= 0)
@@ -80,13 +79,12 @@ counter_barrier_wait (counter_barrier *b)
unlock_counter_barrier (b);
}
-
static inline void
change_internal_barrier_count (counter_barrier *b, int val)
{
b->wait_count += val;
if (b->wait_count <= 0)
- pthread_cond_broadcast (&b->cond);
+ caf_shmem_cond_broadcast (&b->cond);
}
int
@@ -103,19 +101,27 @@ int
counter_barrier_add (counter_barrier *c, int val)
{
int ret;
- pthread_mutex_lock (&c->mutex);
+ caf_shmem_mutex_lock (&c->mutex);
ret = counter_barrier_add_locked (c, val);
- pthread_mutex_unlock (&c->mutex);
+ caf_shmem_mutex_unlock (&c->mutex);
return ret;
}
+void
+counter_barrier_init_add (counter_barrier *b, int val)
+{
+ b->count += val;
+ b->wait_count += val;
+ caf_shmem_cond_update_count (&b->cond, val);
+}
+
int
counter_barrier_get_count (counter_barrier *c)
{
int ret;
- pthread_mutex_lock (&c->mutex);
+ caf_shmem_mutex_lock (&c->mutex);
ret = c->count;
- pthread_mutex_unlock (&c->mutex);
+ caf_shmem_mutex_unlock (&c->mutex);
return ret;
}
diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h
index a28c58812a5..ab3d35ada74 100644
--- a/libgfortran/caf/shmem/counter_barrier.h
+++ b/libgfortran/caf/shmem/counter_barrier.h
@@ -25,7 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#ifndef COUNTER_BARRIER_HDR
#define COUNTER_BARRIER_HDR
-#include <pthread.h>
+#include "thread_support.h"
/* Usable as counter barrier and as waitable counter.
This "class" allows to sync all images acting as a barrier. For this the
@@ -41,8 +41,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
typedef struct
{
- pthread_mutex_t mutex;
- pthread_cond_t cond;
+ caf_shmem_mutex mutex;
+ caf_shmem_condvar cond;
volatile int wait_count;
volatile int curr_wait_group;
volatile int count;
@@ -65,6 +65,10 @@ int counter_barrier_add_locked (counter_barrier *, int);
int counter_barrier_add (counter_barrier *, int);
+/* Add the given number to the counter barrier. This version does not signal.
+ The mutex needs to be locked for this routine to be safe. */
+void counter_barrier_init_add (counter_barrier *, int);
+
/* Get the count of the barrier. */
int counter_barrier_get_count (counter_barrier *);
diff --git a/libgfortran/caf/shmem/shared_memory.c b/libgfortran/caf/shmem/shared_memory.c
index 2b3666ddd3b..d0789a4bac6 100644
--- a/libgfortran/caf/shmem/shared_memory.c
+++ b/libgfortran/caf/shmem/shared_memory.c
@@ -22,6 +22,10 @@ a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
#include "libgfortran.h"
#include "allocator.h"
#include "shared_memory.h"
@@ -30,7 +34,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <fcntl.h>
#include <stdlib.h>
#include <string.h>
+#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
+#elif defined(WIN32)
+#include <Windows.h>
+#include <Memoryapi.h>
+#endif
#include <unistd.h>
/* This implements shared memory based on POSIX mmap. We start with
@@ -56,7 +65,11 @@ shared_memory_set_env (pid_t pid)
char buffer[bufsize];
snprintf (buffer, bufsize, "%d", pid);
+#ifdef HAVE_SETENV
setenv (ENV_PPID, buffer, 1);
+#else
+ SetEnvironmentVariable (ENV_PPID, buffer);
+#endif
#undef bufsize
}
@@ -82,7 +95,7 @@ shared_mem_ptr
shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align)
{
if (mem->glbl.meta->master)
- return (shared_mem_ptr) {mem->glbl.meta->master};
+ return (shared_mem_ptr) {mem->glbl.meta->master};
else
{
ptrdiff_t loc = mem->glbl.meta->used;
@@ -112,7 +125,6 @@ shared_memory_init (shared_memory_act *mem, size_t size)
char shm_name[NAME_MAX];
const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE);
pid_t ppid = getpid ();
- int shm_fd, res;
void *base_ptr;
if (env_val)
@@ -131,70 +143,138 @@ shared_memory_init (shared_memory_act *mem, size_t size)
if (!env_val)
{
- shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
- if (shm_fd == -1)
+#ifdef HAVE_MMAP
+ int res;
+
+ mem->shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
+ if (mem->shm_fd == -1)
{
perror ("creating shared memory segment failed.");
exit (1);
}
- res = ftruncate (shm_fd, size);
+ res = ftruncate (mem->shm_fd, size);
if (res == -1)
{
perror ("resizing shared memory segment failed.");
exit (1);
}
+#elif defined(WIN32)
+ mem->shm_fd
+ = CreateFileMapping (INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE,
+ size >> (sizeof (DWORD) * 8),
+ (DWORD) (size & ~((DWORD) 0)), shm_name);
+ if (mem->shm_fd == NULL)
+ {
+ LPVOID lpMsgBuf;
+ DWORD dw = GetLastError ();
+
+ if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+ | FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, dw,
+ MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &lpMsgBuf, 0, NULL)
+ == 0)
+ {
+ fprintf (stderr, "formatting the error message failed.\n");
+ ExitProcess (dw);
+ }
+
+ fprintf (stderr, "creating shared memory segment failed: %d, %s\n",
+ dw, (LPCTSTR) lpMsgBuf);
+
+ LocalFree (lpMsgBuf);
+ exit (1);
+ }
+#else
+#error "no way to map shared memory."
+#endif
}
else
{
- shm_fd = shm_open (shm_name, O_RDWR, 0);
- if (shm_fd == -1)
+#ifdef HAVE_MMAP
+ mem->shm_fd = shm_open (shm_name, O_RDWR, 0);
+ if (mem->shm_fd == -1)
{
perror ("opening shared memory segment failed.");
exit (1);
}
+#elif defined(WIN32)
+ mem->shm_fd = OpenFileMapping (FILE_MAP_ALL_ACCESS, FALSE, shm_name);
+ if (mem->shm_fd == NULL)
+ {
+ perror ("opening shared memory segment failed.");
+ exit (1);
+ }
+#endif
}
-
+#ifdef HAVE_MMAP
mem->glbl.base
- = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, shm_fd, 0);
- res = close (shm_fd);
+ = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0);
if (mem->glbl.base == MAP_FAILED)
{
perror ("mmap failed");
exit (1);
}
+#elif defined(WIN32)
+ mem->glbl.base
+ = (LPTSTR) MapViewOfFileExNuma (mem->shm_fd, FILE_MAP_ALL_ACCESS, 0, 0,
+ size, base_ptr, NUMA_NO_PREFERRED_NODE);
+ if (mem->glbl.base == NULL)
+ {
+ perror ("MapViewOfFile failed");
+ exit (1);
+ }
+#endif
if (!base_ptr)
{
#define bufsize 20
char buffer[bufsize];
snprintf (buffer, bufsize, "%p", mem->glbl.base);
+#ifdef HAVE_SETENV
setenv (ENV_BASE, buffer, 1);
+#else
+ SetEnvironmentVariable (ENV_BASE, buffer);
+#endif
#undef bufsize
}
- if (res)
- { // from close()
- perror ("closing shm file handle failed. Trying to continue...");
- }
mem->size = size;
if (!env_val)
*mem->glbl.meta
= (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0};
-
}
void
-shared_memory_cleanup (shared_memory_act *)
+shared_memory_cleanup (shared_memory_act *mem)
{
char shm_name[NAME_MAX];
- int res;
snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
+#ifdef HAVE_MMAP
+ int res = munmap (mem->glbl.base, mem->size);
+ if (res)
+ {
+ perror ("unmapping shared memory segment failed");
+ }
+ res = close (mem->shm_fd);
+ if (res)
+ {
+ perror ("closing shm file handle failed. Trying to continue...");
+ }
res = shm_unlink (shm_name);
if (res == -1)
{
perror ("shm_unlink failed");
exit (1);
}
+#elif defined(WIN32)
+ if (!UnmapViewOfFile (mem->glbl.base))
+ {
+ perror ("unmapping shared memory segment failed");
+ }
+ CloseHandle (mem->shm_fd);
+#endif
}
#undef NAME_MAX
diff --git a/libgfortran/caf/shmem/shared_memory.h b/libgfortran/caf/shmem/shared_memory.h
index 01ac2811e5d..3d031875ed2 100644
--- a/libgfortran/caf/shmem/shared_memory.h
+++ b/libgfortran/caf/shmem/shared_memory.h
@@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#ifndef SHARED_MEMORY_H
#define SHARED_MEMORY_H
+#include "thread_support.h"
+
#include <stdlib.h>
#include <stddef.h>
#include <unistd.h>
@@ -47,6 +49,7 @@ typedef struct shared_memory_act
global_shared_memory_meta *meta;
} glbl;
size_t size; // const
+ caf_shmem_fd shm_fd;
} shared_memory_act;
/* A struct to serve as shared memory object. */
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index e4310b03e43..c39ffc6715c 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -22,8 +22,6 @@ a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
-#include "config.h"
-
#include "../caf_error.h"
#include "supervisor.h"
#include "teams_mgmt.h"
@@ -38,6 +36,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#elif HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
+#if !defined(_SC_PAGE_SIZE) && defined(WIN32)
+#include <windows.h>
+#endif
#define GFORTRAN_ENV_NUM_IMAGES "GFORTRAN_NUM_IMAGES"
#define GFORTRAN_ENV_SHARED_MEMORY_SIZE "GFORTRAN_SHARED_MEMORY_SIZE"
@@ -56,8 +57,13 @@ get_image_num_from_envvar (void)
int nimages;
num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES);
if (!num_images_char)
- return sysconf (_SC_NPROCESSORS_ONLN); /* TODO: Make portable. */
- /* TODO: Error checking. */
+#ifdef _SC_NPROCESSORS_ONLN
+ return sysconf (_SC_NPROCESSORS_ONLN);
+#elif defined(WIN32)
+ num_images_char = getenv ("NUMBER_OF_PROCESSORS");
+#else
+#error "Unsupported system: No known way to get number of cores!"
+#endif
nimages = atoi (num_images_char);
return nimages;
}
@@ -105,7 +111,12 @@ get_memory_size_from_envvar (void)
if (sizeof (size_t) == 4)
sz = ((size_t) 1) << 28;
else
+#ifndef WIN32
sz = ((size_t) 1) << 34;
+#else
+ /* Use 1GB on Windows. */
+ sz = ((size_t) 1) << 30;
+#endif
}
return sz;
}
@@ -146,7 +157,19 @@ ensure_shmem_initialization (void)
return;
local = malloc (sizeof (image_local));
+#if defined(_SC_PAGE_SIZE)
pagesize = sysconf (_SC_PAGE_SIZE);
+#elif defined(WIN32)
+ {
+ SYSTEM_INFO si;
+ GetNativeSystemInfo (&si);
+ pagesize = si.dwAllocationGranularity;
+ }
+#else
+#warning \
+ "Unsupported system: No known way to get memory page size. Assuming 4k!"
+ pagesize = 4096;
+#endif
shmem_size = round_to_pagesize (get_memory_size_from_envvar ());
local->total_num_images = get_image_num_from_envvar ();
shared_memory_init (&local->sm, shmem_size);
@@ -199,6 +222,7 @@ ensure_shmem_initialization (void)
{
this_image = (image) {-1, get_supervisor ()};
this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM;
+ thread_support_init_supervisor ();
counter_barrier_init (&this_image.supervisor->num_active_images,
local->total_num_images);
alloc_init_supervisor (&local->ai, &local->sm);
@@ -206,16 +230,31 @@ ensure_shmem_initialization (void)
}
}
+#if !defined(environ)
extern char **environ;
+#endif
+/* argc and argv may not be used on certain OSes. Flag them unused therefore.
+ */
int
-supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
- int *exit_code)
+supervisor_main_loop (int *argc __attribute__ ((unused)),
+ char ***argv __attribute__ ((unused)), int *exit_code)
{
supervisor *m;
- pid_t new_pid, finished_pid;
image im;
+#if defined(WIN32) && !defined(HAVE_FORK)
+ HANDLE *process_handles = malloc (sizeof (HANDLE) * local->total_num_images),
+ *thread_handles = malloc (sizeof (HANDLE) * local->total_num_images),
+ *waiting_handles = malloc (sizeof (HANDLE) * local->total_num_images);
+ int count_waiting = local->total_num_images;
+ LPTCH *envs = malloc (sizeof (LPTCH) * local->total_num_images);
+ LPTSTR currentDir;
+ DWORD cdLen = GetCurrentDirectory (0, NULL);
+ currentDir = malloc (cdLen);
+ GetCurrentDirectory (cdLen, currentDir);
+#else
int chstatus;
+#endif
*exit_code = 0;
shared_memory_set_env (getpid ());
@@ -223,6 +262,8 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
{
+#ifdef HAVE_FORK
+ caf_shmem_pid new_pid;
if ((new_pid = fork ()))
{
if (new_pid == -1)
@@ -247,10 +288,63 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
execve ((*argv)[0], *argv, new_env);
return 1;
}
+#elif defined(WIN32)
+ LPTCH new_env;
+ size_t n = 0, es;
+ STARTUPINFO si;
+ DWORD dwFlags = 0;
+ PROCESS_INFORMATION pi;
+ LPTCH env = GetEnvironmentStrings ();
+
+ ZeroMemory (&si, sizeof (si));
+ si.cb = sizeof (si);
+ ZeroMemory (&pi, sizeof (pi));
+
+ /* Count the number of characters in the current environment. */
+ for (LPTSTR e = (LPTSTR) env; *e; es = lstrlen (e) + 1, e += es, n += es)
+ ;
+ new_env = (LPCH) malloc (n + 32 * sizeof (TCHAR));
+ memcpy (new_env, env, n);
+ snprintf (&((TCHAR *) new_env)[n], 32, "%s=%d%c", GFORTRAN_ENV_IMAGE_NUM,
+ im.image_num, (char) 0);
+ if (!CreateProcessA (NULL, GetCommandLine (), NULL, NULL, FALSE, dwFlags,
+ new_env, currentDir, &si, &pi))
+ {
+ LPVOID lpMsgBuf;
+ DWORD dw = GetLastError ();
+
+ if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+ | FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, dw,
+ MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &lpMsgBuf, 0, NULL)
+ == 0)
+ {
+ fprintf (stderr, "formatting the error message failed.\n");
+ ExitProcess (dw);
+ }
+
+ fprintf (stderr, "error spawning child: %ld, %s\n", dw,
+ (LPCTSTR) lpMsgBuf);
+
+ LocalFree (lpMsgBuf);
+ exit (1);
+ }
+ m->images[im.image_num] = (image_tracker) {pi.hProcess, IMAGE_OK};
+ process_handles[im.image_num] = waiting_handles[im.image_num]
+ = pi.hProcess;
+ thread_handles[im.image_num] = pi.hThread;
+ envs[im.image_num] = new_env;
+#else
+#error "no way known to start child processes."
+#endif
}
- for (int j, i = 0; i < local->total_num_images; i++)
+ for (int i = 0; i < local->total_num_images; i++)
{
- finished_pid = wait (&chstatus);
+#ifdef HAVE_FORK
+ caf_shmem_pid finished_pid = wait (&chstatus);
+ int j;
if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
{
for (j = 0;
@@ -303,10 +397,77 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
}
/* Trigger waiting sync images aka sync_table. */
for (j = 0; j < local->total_num_images; j++)
- pthread_cond_signal (&SHMPTR_AS (pthread_cond_t *,
- m->sync_shared.sync_images_cond_vars,
- &local->sm)[j]);
+ caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
+ m->sync_shared.sync_images_cond_vars,
+ &local->sm)[j]);
counter_barrier_add (&m->num_active_images, -1);
+#elif defined(WIN32)
+ DWORD res = WaitForMultipleObjects (count_waiting, waiting_handles, FALSE,
+ INFINITE);
+ HANDLE cand;
+ bool progress = false;
+ DWORD process_exit_code;
+ if (res == WAIT_FAILED)
+ caf_runtime_error ("waiting for process termination failed.");
+ int index = res - WAIT_OBJECT_0, finished_process;
+ bool fail;
+
+ do
+ {
+ cand = waiting_handles[index];
+ for (finished_process = 0;
+ finished_process < local->total_num_images
+ && cand != process_handles[finished_process];
+ ++finished_process)
+ ;
+
+ GetExitCodeProcess (cand, &process_exit_code);
+ fail = process_exit_code != 0;
+ fprintf (stderr, "terminating process %d with fail status %d (%ld)\n",
+ finished_process, fail, process_exit_code);
+ if (finished_process < local->total_num_images)
+ {
+ CloseHandle (process_handles[finished_process]);
+ process_handles[finished_process] = NULL;
+ CloseHandle (thread_handles[finished_process]);
+ FreeEnvironmentStrings (envs[finished_process]);
+ if (fail)
+ {
+ m->images[finished_process].status = IMAGE_FAILED;
+ atomic_fetch_add (&m->failed_images, 1);
+ if (*exit_code < process_exit_code)
+ *exit_code = process_exit_code;
+ }
+ else
+ {
+ m->images[finished_process].status = IMAGE_SUCCESS;
+ atomic_fetch_add (&m->finished_images, 1);
+ }
+ }
+ memmove (&waiting_handles[index], &waiting_handles[index + 1],
+ sizeof (HANDLE) * (count_waiting - index - 1));
+ --count_waiting;
+ counter_barrier_add (&m->num_active_images, -1);
+
+ /* Check if more than one process has terminated already. */
+ progress = false;
+ for (index = 0; index < count_waiting; ++index)
+ if (WaitForSingleObject (waiting_handles[index], 0)
+ == WAIT_OBJECT_0)
+ {
+ progress = true;
+ ++i;
+ break;
+ }
+ }
+ while (progress && count_waiting > 0);
+#endif
}
+
+#if defined(WIN32) && !defined(HAVE_FORK)
+ free (process_handles);
+ free (thread_handles);
+ free (envs);
+#endif
return 0;
}
diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h
index 7afb8269674..7e5e19702e4 100644
--- a/libgfortran/caf/shmem/supervisor.h
+++ b/libgfortran/caf/shmem/supervisor.h
@@ -25,6 +25,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#ifndef SUPERVISOR_H
#define SUPERVISOR_H
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
#include "caf/libcaf.h"
#include "alloc.h"
#include "collective_subroutine.h"
@@ -42,7 +46,7 @@ typedef enum
typedef struct
{
- pid_t pid;
+ caf_shmem_pid pid;
image_status status;
} image_tracker;
@@ -56,7 +60,10 @@ typedef struct supervisor
atomic_int failed_images;
atomic_int finished_images;
counter_barrier num_active_images;
- pthread_mutex_t image_tracker_lock;
+ caf_shmem_mutex image_tracker_lock;
+#ifdef WIN32
+ size_t global_used_handles;
+#endif
image_tracker images[];
} supervisor;
diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c
index a456244629c..e1020a1e864 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -33,13 +33,13 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
static inline void
lock_table (sync_t *si)
{
- pthread_mutex_lock (&si->cis->sync_images_table_lock);
+ caf_shmem_mutex_lock (&si->cis->sync_images_table_lock);
}
static inline void
unlock_table (sync_t *si)
{
- pthread_mutex_unlock (&si->cis->sync_images_table_lock);
+ caf_shmem_mutex_unlock (&si->cis->sync_images_table_lock);
}
void
@@ -48,7 +48,7 @@ sync_init (sync_t *si, shared_memory sm)
*si = (sync_t) {
&this_image.supervisor->sync_shared,
SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm),
- SHMPTR_AS (pthread_cond_t *,
+ SHMPTR_AS (caf_shmem_condvar *,
this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};
}
@@ -61,7 +61,7 @@ sync_init_supervisor (sync_t *si, alloc *ai)
si->cis = &this_image.supervisor->sync_shared;
initialize_shared_mutex (&si->cis->event_lock);
- initialize_shared_condition (&si->cis->event_cond);
+ initialize_shared_condition (&si->cis->event_cond, num_images);
initialize_shared_mutex (&si->cis->sync_images_table_lock);
@@ -69,14 +69,14 @@ sync_init_supervisor (sync_t *si, alloc *ai)
= allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes);
si->cis->sync_images_cond_vars
= allocator_shared_malloc (alloc_get_allocator (ai),
- sizeof (pthread_cond_t) * num_images);
+ sizeof (caf_shmem_condvar) * num_images);
si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
si->triggers
- = SHMPTR_AS (pthread_cond_t *, si->cis->sync_images_cond_vars, ai->mem);
+ = SHMPTR_AS (caf_shmem_condvar *, si->cis->sync_images_cond_vars, ai->mem);
for (int i = 0; i < num_images; i++)
- initialize_shared_condition (&si->triggers[i]);
+ initialize_shared_condition (&si->triggers[i], num_images);
memset (si->table, 0, table_size_in_bytes);
}
@@ -103,7 +103,7 @@ sync_table (sync_t *si, int *images, int size)
for (i = 0; i < size; ++i)
{
++table[images[i] + img_c * this_image.image_num];
- pthread_cond_signal (&si->triggers[images[i]]);
+ caf_shmem_cond_signal (&si->triggers[images[i]]);
}
for (;;)
{
@@ -114,7 +114,7 @@ sync_table (sync_t *si, int *images, int size)
break;
if (i == size)
break;
- pthread_cond_wait (&si->triggers[this_image.image_num],
+ caf_shmem_cond_wait (&si->triggers[this_image.image_num],
&si->cis->sync_images_table_lock);
}
}
@@ -127,7 +127,7 @@ sync_table (sync_t *si, int *images, int size)
if (this_image.supervisor->images[map[i]].status != IMAGE_OK)
continue;
++table[map[i] + size * this_image.image_num];
- pthread_cond_signal (&si->triggers[map[i]]);
+ caf_shmem_cond_signal (&si->triggers[map[i]]);
}
for (;;)
{
@@ -138,7 +138,7 @@ sync_table (sync_t *si, int *images, int size)
break;
if (i == size)
break;
- pthread_cond_wait (&si->triggers[this_image.image_num],
+ caf_shmem_cond_wait (&si->triggers[this_image.image_num],
&si->cis->sync_images_table_lock);
}
}
@@ -160,23 +160,23 @@ sync_team (caf_shmem_team_t team)
void
lock_event (sync_t *si)
{
- pthread_mutex_lock (&si->cis->event_lock);
+ caf_shmem_mutex_lock (&si->cis->event_lock);
}
void
unlock_event (sync_t *si)
{
- pthread_mutex_unlock (&si->cis->event_lock);
+ caf_shmem_mutex_unlock (&si->cis->event_lock);
}
void
event_post (sync_t *si)
{
- pthread_cond_broadcast (&si->cis->event_cond);
+ caf_shmem_cond_broadcast (&si->cis->event_cond);
}
void
event_wait (sync_t *si)
{
- pthread_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
+ caf_shmem_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
}
diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h
index a3e586bca24..a6d20614b67 100644
--- a/libgfortran/caf/shmem/sync.h
+++ b/libgfortran/caf/shmem/sync.h
@@ -28,13 +28,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "alloc.h"
#include "counter_barrier.h"
-#include <pthread.h>
-
typedef struct {
/* Mutex and condition variable needed for signaling events. */
- pthread_mutex_t event_lock;
- pthread_cond_t event_cond;
- pthread_mutex_t sync_images_table_lock;
+ caf_shmem_mutex event_lock;
+ caf_shmem_condvar event_cond;
+ caf_shmem_mutex sync_images_table_lock;
shared_mem_ptr sync_images_table;
shared_mem_ptr sync_images_cond_vars;
} sync_shared;
@@ -42,10 +40,10 @@ typedef struct {
typedef struct {
sync_shared *cis;
int *table; // we can cache the table and the trigger pointers here
- pthread_cond_t *triggers;
+ caf_shmem_condvar *triggers;
} sync_t;
-typedef pthread_mutex_t lock_t;
+typedef caf_shmem_mutex lock_t;
typedef int event_t;
diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c
index 44a34d727c3..9bf8db2302c 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -31,7 +31,7 @@ caf_shmem_team_t caf_teams_formed = NULL;
void
update_teams_images (caf_shmem_team_t team)
{
- pthread_mutex_lock (&team->u.image_info->image_count.mutex);
+ caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex);
if (team->u.image_info->num_term_images
!= this_image.supervisor->finished_images
+ this_image.supervisor->failed_images)
@@ -52,7 +52,7 @@ update_teams_images (caf_shmem_team_t team)
old_num
- team->u.image_info->num_term_images);
}
- pthread_mutex_unlock (&team->u.image_info->image_count.mutex);
+ caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
}
void
diff --git a/libgfortran/caf/shmem/thread_support.c b/libgfortran/caf/shmem/thread_support.c
old mode 100644
new mode 100755
index 572f39400b3..e2c53627c2f
--- a/libgfortran/caf/shmem/thread_support.c
+++ b/libgfortran/caf/shmem/thread_support.c
@@ -28,6 +28,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <stdlib.h>
#include <stdio.h>
+#if !defined(WIN32) && !defined(__CYGWIN__)
+#include <pthread.h>
+
#define ERRCHECK(a) \
do \
{ \
@@ -42,7 +45,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
while (0)
void
-initialize_shared_mutex (pthread_mutex_t *mutex)
+initialize_shared_mutex (caf_shmem_mutex *mutex)
{
pthread_mutexattr_t mattr;
ERRCHECK (pthread_mutexattr_init (&mattr));
@@ -52,18 +55,18 @@ initialize_shared_mutex (pthread_mutex_t *mutex)
}
void
-initialize_shared_errorcheck_mutex (pthread_mutex_t *mutex)
+initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex)
{
pthread_mutexattr_t mattr;
ERRCHECK (pthread_mutexattr_init (&mattr));
- ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));
+ ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
ERRCHECK (pthread_mutex_init (mutex, &mattr));
ERRCHECK (pthread_mutexattr_destroy (&mattr));
}
void
-initialize_shared_condition (pthread_cond_t *cond)
+initialize_shared_condition (caf_shmem_condvar *cond, const int)
{
pthread_condattr_t cattr;
ERRCHECK (pthread_condattr_init (&cattr));
@@ -71,3 +74,302 @@ initialize_shared_condition (pthread_cond_t *cond)
ERRCHECK (pthread_cond_init (cond, &cattr));
ERRCHECK (pthread_condattr_destroy (&cattr));
}
+#else
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include <windows.h>
+#include <assert.h>
+
+static HANDLE *handles = NULL;
+static size_t cap_handles = 0;
+
+static const int ULONGBITS = sizeof (unsigned long) << 3; // *8
+
+static size_t
+smax (size_t a, size_t b)
+{
+ return a < b ? b : a;
+}
+
+static HANDLE
+get_handle (const size_t id, const char t)
+{
+ const int add = t == 'c' ? 1 : 0;
+ while (id + add >= cap_handles)
+ {
+ cap_handles += 1024;
+ if (handles)
+ handles = realloc (handles, sizeof (HANDLE) * cap_handles);
+ else
+ handles = malloc (sizeof (HANDLE) * cap_handles);
+ if (!handles)
+ caf_runtime_error (
+ "can not get buffer for synchronication objects, aborting");
+
+ memset (&handles[cap_handles - 1024], 0, sizeof (HANDLE) * 1024);
+ }
+ if (!handles[id])
+ {
+ static char *pid = NULL;
+ char name[MAX_PATH];
+
+ if (!pid)
+ pid = shared_memory_get_env ();
+ snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd", pid, t, id);
+ switch (t)
+ {
+ case 'm':
+ handles[id] = CreateMutex (NULL, false, name);
+ break;
+ case 'c':
+ {
+ handles[id] = CreateSemaphore (NULL, 0, __INT_MAX__, name);
+ snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd_lock", pid, t,
+ id);
+ handles[id + 1] = CreateSemaphore (NULL, 1, 1, name);
+ this_image.supervisor->global_used_handles
+ = smax (this_image.supervisor->global_used_handles, id + 2);
+ break;
+ }
+ default:
+ caf_runtime_error ("Unknown handle type %c", t);
+ exit (1);
+ }
+ if (handles[id] == NULL)
+ {
+ caf_runtime_error (
+ "Could not create synchronisation object, error: %d",
+ GetLastError ());
+ return NULL;
+ }
+
+ this_image.supervisor->global_used_handles
+ = smax (this_image.supervisor->global_used_handles, id + 1);
+ }
+
+ return handles[id];
+}
+
+static HANDLE
+get_mutex (caf_shmem_mutex *m)
+{
+ return get_handle (m->id, 'm');
+}
+
+static HANDLE
+get_condvar (caf_shmem_condvar *cv)
+{
+ return get_handle (cv->id, 'c');
+}
+
+void
+thread_support_init_supervisor (void)
+{
+ if (local->total_num_images > ULONGBITS * MAX_NUM_SIGNALED)
+ caf_runtime_error ("Maximum number of supported images is %zd.",
+ ULONGBITS * MAX_NUM_SIGNALED);
+ this_image.supervisor->global_used_handles = 0;
+}
+
+int
+caf_shmem_mutex_lock (caf_shmem_mutex *m)
+{
+ HANDLE mutex = get_mutex (m);
+ DWORD res = WaitForSingleObject (mutex, INFINITE);
+
+ /* Return zero on success. */
+ return res != WAIT_OBJECT_0;
+}
+
+int
+caf_shmem_mutex_trylock (caf_shmem_mutex *m)
+{
+ HANDLE mutex = get_mutex (m);
+ DWORD res = WaitForSingleObject (mutex, 0);
+
+ return res == WAIT_OBJECT_0 ? 0 : EBUSY;
+}
+
+int
+caf_shmem_mutex_unlock (caf_shmem_mutex *m)
+{
+ HANDLE mutex = get_mutex (m);
+ BOOL res = ReleaseMutex (mutex);
+
+ if (!res)
+ {
+ LPVOID lpMsgBuf;
+ DWORD dw = GetLastError ();
+
+ if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+ | FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, dw, MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &lpMsgBuf, 0, NULL)
+ == 0)
+ {
+ fprintf (stderr, "%d: formatting the error message failed.\n",
+ this_image.image_num);
+ ExitProcess (dw);
+ }
+
+ fprintf (stderr, "%d: unlock mutex failed: %d, %s\n",
+ this_image.image_num, dw, (LPCTSTR) lpMsgBuf);
+
+ LocalFree (lpMsgBuf);
+ }
+ return res ? 0 : EPERM;
+}
+
+static bool
+bm_is_set (volatile unsigned long mask[], const int b)
+{
+ return (mask[b / ULONGBITS] & (1UL << (b % ULONGBITS))) != 0;
+}
+
+static void
+bm_clear_bit (volatile unsigned long mask[], const int b)
+{
+ mask[b / ULONGBITS] &= ~(1UL << (b % ULONGBITS));
+}
+
+static void
+bm_set_mask (volatile unsigned long mask[], const int size)
+{
+ const int entries = size / ULONGBITS;
+ const int rem = size % ULONGBITS;
+ int i = 0;
+ assert (entries >= 0);
+
+ for (; i < entries; ++i)
+ mask[i] = ~0UL;
+ if (rem != 0)
+ mask[i] = ~0UL >> (ULONGBITS - rem);
+}
+
+__attribute_used__ static bool
+bm_is_none (volatile unsigned long mask[], const int size)
+{
+ const int entries = size / ULONGBITS;
+ const int rem = size % ULONGBITS;
+ int i = 0;
+ for (; i < entries; ++i)
+ if (mask[i] != 0)
+ return false;
+
+ return rem == 0 || ((mask[i] & (~0UL >> (ULONGBITS - rem))) == 0);
+}
+
+void
+caf_shmem_cond_wait (caf_shmem_condvar *cv, caf_shmem_mutex *m)
+{
+ HANDLE mutex = get_mutex (m), condvar = get_condvar (cv),
+ lock = get_handle (cv->id + 1, 'c');
+ HANDLE entry[3] = {mutex, condvar, lock};
+ int res;
+
+ WaitForSingleObject (lock, INFINITE);
+ for (;;)
+ {
+ if (bm_is_set (cv->signaled, this_image.image_num) || cv->any)
+ {
+ break;
+ }
+ ReleaseMutex (mutex);
+ ReleaseSemaphore (lock, 1, NULL);
+ res = WaitForMultipleObjects (3, entry, true, INFINITE);
+ if (res != WAIT_OBJECT_0)
+ {
+ fprintf (stderr, "%d: failed to get all wait for: %d\n",
+ this_image.image_num, res);
+ fflush (stderr);
+ }
+ ReleaseSemaphore (condvar, 1, NULL);
+ }
+ res = WaitForSingleObject (condvar, INFINITE);
+ if (res != WAIT_OBJECT_0)
+ {
+ fprintf (stderr, "%d: failed to get condvar: %d\n", this_image.image_num,
+ res);
+ fflush (stderr);
+ }
+
+ bm_clear_bit (cv->signaled, this_image.image_num);
+ cv->any = 0;
+ ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_broadcast (caf_shmem_condvar *cv)
+{
+ HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
+
+ WaitForSingleObject (lock, INFINITE);
+ bm_set_mask (cv->signaled, cv->size);
+ bm_clear_bit (cv->signaled, this_image.image_num);
+
+ ReleaseSemaphore (condvar, cv->size, NULL);
+ ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_signal (caf_shmem_condvar *cv)
+{
+ HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
+
+ if (caf_current_team)
+ {
+ WaitForSingleObject (lock, INFINITE);
+ }
+ else
+ return;
+ /* The first image is zero, which wouldn't allow it to signal. */
+ cv->any = this_image.image_num + 1;
+ ReleaseSemaphore (condvar, 1, NULL);
+ ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_update_count (caf_shmem_condvar *cv, int val)
+{
+ cv->size += val;
+}
+
+void
+initialize_shared_mutex (caf_shmem_mutex *m)
+{
+ *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
+
+ get_mutex (m);
+}
+
+void
+initialize_shared_errorcheck_mutex (caf_shmem_mutex *m)
+{
+ *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
+
+ get_mutex (m);
+}
+
+void
+initialize_shared_condition (caf_shmem_condvar *cv, const int size)
+{
+ *cv = (caf_shmem_condvar) {this_image.supervisor->global_used_handles,
+ 0,
+ size,
+ {}};
+
+ memset ((void *) cv->signaled, 0, sizeof (unsigned long) * MAX_NUM_SIGNALED);
+ get_condvar (cv);
+ assert (bm_is_none (cv->signaled, cv->size));
+}
+
+void
+thread_support_cleanup (void)
+{
+ for (size_t i = 0; i < this_image.supervisor->global_used_handles; ++i)
+ if (handles[i])
+ CloseHandle (handles[i]);
+}
+#endif
diff --git a/libgfortran/caf/shmem/thread_support.h b/libgfortran/caf/shmem/thread_support.h
old mode 100644
new mode 100755
index e70b4b83c7d..351cdbbb868
--- a/libgfortran/caf/shmem/thread_support.h
+++ b/libgfortran/caf/shmem/thread_support.h
@@ -25,14 +25,89 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#ifndef THREAD_SUPPORT_H
#define THREAD_SUPPORT_H
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#ifndef WIN32
+#include <sys/types.h>
+
+typedef pid_t caf_shmem_pid;
+typedef int caf_shmem_fd;
+#else
+#include <handleapi.h>
+
+typedef HANDLE caf_shmem_pid;
+typedef HANDLE caf_shmem_fd;
+#endif
+
+#if !defined(WIN32) && !defined(__CYGWIN__)
#include <pthread.h>
+typedef pthread_mutex_t caf_shmem_mutex;
+typedef pthread_cond_t caf_shmem_condvar;
+
+#define CAF_SHMEM_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER
+#define CAF_SHMEM_COND_INITIALIZER PTHREAD_COND_INITIALIZER
+
+#define thread_support_init_supervisor() (void) 0
+
+#define caf_shmem_mutex_lock pthread_mutex_lock
+#define caf_shmem_mutex_trylock pthread_mutex_trylock
+#define caf_shmem_mutex_unlock pthread_mutex_unlock
+
+#define caf_shmem_cond_wait pthread_cond_wait
+#define caf_shmem_cond_broadcast pthread_cond_broadcast
+#define caf_shmem_cond_signal pthread_cond_signal
+#define caf_shmem_cond_update_count(c, v) (void) 0
+
+#define thread_support_cleanup() (void) 0
+#else
+#include <synchapi.h>
+#include <stddef.h>
+
+typedef struct caf_shmem_mutex
+{
+ size_t id;
+} caf_shmem_mutex;
+
+#define MAX_NUM_SIGNALED 8
+
+typedef struct caf_shmem_condvar
+{
+ size_t id;
+ volatile int any;
+ int size;
+ volatile unsigned long signaled[MAX_NUM_SIGNALED];
+} caf_shmem_condvar;
+
+#define CAF_SHMEM_MUTEX_INITIALIZER (caf_shmem_mutex){0}
+#define CAF_SHMEM_COND_INITIALIZER \
+ (caf_shmem_condvar) \
+ { \
+ 0, 0, 0, {} \
+ }
+
+void thread_support_init_supervisor (void);
+
+int caf_shmem_mutex_lock (caf_shmem_mutex *);
+int caf_shmem_mutex_trylock (caf_shmem_mutex *);
+int caf_shmem_mutex_unlock (caf_shmem_mutex *);
+
+void caf_shmem_cond_wait (caf_shmem_condvar *, caf_shmem_mutex *);
+void caf_shmem_cond_broadcast (caf_shmem_condvar *);
+void caf_shmem_cond_signal (caf_shmem_condvar *);
+void caf_shmem_cond_update_count (caf_shmem_condvar *, int);
+
+void thread_support_cleanup (void);
+#endif
+
/* Support routines to setup pthread structs in shared memory. */
-void initialize_shared_mutex (pthread_mutex_t *);
+void initialize_shared_mutex (caf_shmem_mutex *);
-void initialize_shared_errorcheck_mutex (pthread_mutex_t *);
+void initialize_shared_errorcheck_mutex (caf_shmem_mutex *);
-void initialize_shared_condition (pthread_cond_t *);
+void initialize_shared_condition (caf_shmem_condvar *, const int size);
#endif
