Actual source code: mpmpishm.c

      1: #include <petscsys.h>
      2: #include <petsc/private/petscimpl.h>
      3: #include <pthread.h>
      4: #include <hwloc.h>
      5: #include <omp.h>

      7: /* Use mmap() to allocate shared mmeory (for the pthread_barrier_t object) if it is available,
      8:    otherwise use MPI_Win_allocate_shared. They should have the same effect except MPI-3 is much
      9:    simpler to use. However, on a Cori Haswell node with Cray MPI, MPI-3 worsened a test's performance
     10:    by 50%. Until the reason is found out, we use mmap() instead.
     11: */
     12: #define USE_MMAP_ALLOCATE_SHARED_MEMORY

     14: #if defined(USE_MMAP_ALLOCATE_SHARED_MEMORY) && defined(PETSC_HAVE_MMAP)
     15:   #include <sys/mman.h>
     16:   #include <sys/types.h>
     17:   #include <sys/stat.h>
     18:   #include <fcntl.h>
     19: #endif

     21: struct _n_PetscOmpCtrl {
     22:   MPI_Comm           omp_comm;        /* a shared memory communicator to spawn omp threads */
     23:   MPI_Comm           omp_master_comm; /* a communicator to give to third party libraries */
     24:   PetscMPIInt        omp_comm_size;   /* size of omp_comm, a kind of OMP_NUM_THREADS */
     25:   PetscBool          is_omp_master;   /* rank 0's in omp_comm */
     26:   MPI_Win            omp_win;         /* a shared memory window containing a barrier */
     27:   pthread_barrier_t *barrier;         /* pointer to the barrier */
     28:   hwloc_topology_t   topology;
     29:   hwloc_cpuset_t     cpuset;     /* cpu bindings of omp master */
     30:   hwloc_cpuset_t     omp_cpuset; /* union of cpu bindings of ranks in omp_comm */
     31: };

     33: /* Allocate and initialize a pthread_barrier_t object in memory shared by processes in omp_comm
     34:    contained by the controller.

     36:    PETSc OpenMP controller users do not call this function directly. This function exists
     37:    only because we want to separate shared memory allocation methods from other code.
     38:  */
     39: static inline PetscErrorCode PetscOmpCtrlCreateBarrier(PetscOmpCtrl ctrl)
     40: {
     41:   MPI_Aint              size;
     42:   void                 *baseptr;
     43:   pthread_barrierattr_t attr;

     45: #if defined(USE_MMAP_ALLOCATE_SHARED_MEMORY) && defined(PETSC_HAVE_MMAP)
     46:   int  fd;
     47:   char pathname[PETSC_MAX_PATH_LEN];
     48: #else
     49:   PetscMPIInt disp_unit;
     50: #endif

     52:   PetscFunctionBegin;
     53: #if defined(USE_MMAP_ALLOCATE_SHARED_MEMORY) && defined(PETSC_HAVE_MMAP)
     54:   size = sizeof(pthread_barrier_t);
     55:   if (ctrl->is_omp_master) {
     56:     /* use PETSC_COMM_SELF in PetscGetTmp, since it is a collective call. Using omp_comm would otherwise bcast the partially populated pathname to slaves */
     57:     PetscCall(PetscGetTmp(PETSC_COMM_SELF, pathname, PETSC_MAX_PATH_LEN));
     58:     PetscCall(PetscStrlcat(pathname, "/petsc-shm-XXXXXX", PETSC_MAX_PATH_LEN));
     59:     /* mkstemp replaces XXXXXX with a unique file name and opens the file for us */
     60:     fd = mkstemp(pathname);
     61:     PetscCheck(fd != -1, PETSC_COMM_SELF, PETSC_ERR_LIB, "Could not create tmp file %s with mkstemp", pathname);
     62:     PetscCallExternal(ftruncate, fd, size);
     63:     baseptr = mmap(NULL, size, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0);
     64:     PetscCheck(baseptr != MAP_FAILED, PETSC_COMM_SELF, PETSC_ERR_LIB, "mmap() failed");
     65:     PetscCallExternal(close, fd);
     66:     PetscCallMPI(MPI_Bcast(pathname, PETSC_MAX_PATH_LEN, MPI_CHAR, 0, ctrl->omp_comm));
     67:     /* this MPI_Barrier is to wait slaves to open the file before master unlinks it */
     68:     PetscCallMPI(MPI_Barrier(ctrl->omp_comm));
     69:     PetscCallExternal(unlink, pathname);
     70:   } else {
     71:     PetscCallMPI(MPI_Bcast(pathname, PETSC_MAX_PATH_LEN, MPI_CHAR, 0, ctrl->omp_comm));
     72:     fd = open(pathname, O_RDWR);
     73:     PetscCheck(fd != -1, PETSC_COMM_SELF, PETSC_ERR_LIB, "Could not open tmp file %s", pathname);
     74:     baseptr = mmap(NULL, size, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0);
     75:     PetscCheck(baseptr != MAP_FAILED, PETSC_COMM_SELF, PETSC_ERR_LIB, "mmap() failed");
     76:     PetscCallExternal(close, fd);
     77:     PetscCallMPI(MPI_Barrier(ctrl->omp_comm));
     78:   }
     79: #else
     80:   size = ctrl->is_omp_master ? sizeof(pthread_barrier_t) : 0;
     81:   PetscCallMPI(MPI_Win_allocate_shared(size, 1, MPI_INFO_NULL, ctrl->omp_comm, &baseptr, &ctrl->omp_win));
     82:   PetscCallMPI(MPI_Win_shared_query(ctrl->omp_win, 0, &size, &disp_unit, &baseptr));
     83: #endif
     84:   ctrl->barrier = (pthread_barrier_t *)baseptr;

     86:   /* omp master initializes the barrier */
     87:   if (ctrl->is_omp_master) {
     88:     PetscCallMPI(MPI_Comm_size(ctrl->omp_comm, &ctrl->omp_comm_size));
     89:     PetscCallExternal(pthread_barrierattr_init, &attr);
     90:     PetscCallExternal(pthread_barrierattr_setpshared, &attr, PTHREAD_PROCESS_SHARED); /* make the barrier also work for processes */
     91:     PetscCallExternal(pthread_barrier_init, ctrl->barrier, &attr, (unsigned int)ctrl->omp_comm_size);
     92:     PetscCallExternal(pthread_barrierattr_destroy, &attr);
     93:   }

     95:   /* this MPI_Barrier is to make sure the omp barrier is initialized before slaves use it */
     96:   PetscCallMPI(MPI_Barrier(ctrl->omp_comm));
     97:   PetscFunctionReturn(PETSC_SUCCESS);
     98: }

    100: /* Destroy the pthread barrier in the PETSc OpenMP controller */
    101: static inline PetscErrorCode PetscOmpCtrlDestroyBarrier(PetscOmpCtrl ctrl)
    102: {
    103:   PetscFunctionBegin;
    104:   /* this MPI_Barrier is to make sure slaves have finished using the omp barrier before master destroys it */
    105:   PetscCallMPI(MPI_Barrier(ctrl->omp_comm));
    106:   if (ctrl->is_omp_master) PetscCallExternal(pthread_barrier_destroy, ctrl->barrier);

    108: #if defined(USE_MMAP_ALLOCATE_SHARED_MEMORY) && defined(PETSC_HAVE_MMAP)
    109:   PetscCallExternal(munmap, ctrl->barrier, sizeof(pthread_barrier_t));
    110: #else
    111:   PetscCallMPI(MPI_Win_free(&ctrl->omp_win));
    112: #endif
    113:   PetscFunctionReturn(PETSC_SUCCESS);
    114: }

    116: /*@C
    117:   PetscOmpCtrlCreate - create a PETSc OpenMP controller, which manages PETSc's interaction with third party libraries that use OpenMP

    119:   Input Parameters:
    120: + petsc_comm - a communicator some PETSc object (for example, a matrix) lives in
    121: - nthreads   - number of threads per MPI rank to spawn in a library using OpenMP. If nthreads = -1, let PETSc decide a suitable value

    123:   Output Parameter:
    124: . pctrl - a PETSc OpenMP controller

    126:   Level: developer

    128:   Developer Note:
    129:   Possibly use the variable `PetscNumOMPThreads` to determine the number for threads to use

    131: .seealso: `PetscOmpCtrlDestroy()`, `PetscOmpCtrlGetOmpComms()`, `PetscOmpCtrlBarrier()`, `PetscOmpCtrlOmpRegionOnMasterBegin()`, `PetscOmpCtrlOmpRegionOnMasterEnd()`
    132: @*/
    133: PetscErrorCode PetscOmpCtrlCreate(MPI_Comm petsc_comm, PetscInt nthreads, PetscOmpCtrl *pctrl)
    134: {
    135:   PetscOmpCtrl   ctrl;
    136:   unsigned long *cpu_ulongs = NULL;
    137:   PetscShmComm   pshmcomm;
    138:   MPI_Comm       shm_comm;
    139:   PetscMPIInt    shm_rank, shm_comm_size, omp_rank, color, nr_cpu_ulongs;
    140:   PetscInt       num_packages, num_cores;

    142:   PetscFunctionBegin;
    143:   PetscCall(PetscNew(&ctrl));

    145:   /*=================================================================================
    146:     Init hwloc
    147:    ==================================================================================*/
    148:   PetscCallExternal(hwloc_topology_init, &ctrl->topology);
    149: #if HWLOC_API_VERSION >= 0x00020000
    150:   /* to filter out unneeded info and have faster hwloc_topology_load */
    151:   PetscCallExternal(hwloc_topology_set_all_types_filter, ctrl->topology, HWLOC_TYPE_FILTER_KEEP_NONE);
    152:   PetscCallExternal(hwloc_topology_set_type_filter, ctrl->topology, HWLOC_OBJ_CORE, HWLOC_TYPE_FILTER_KEEP_ALL);
    153: #endif
    154:   PetscCallExternal(hwloc_topology_load, ctrl->topology);

    156:   /*=================================================================================
    157:     Split petsc_comm into multiple omp_comms. Ranks in an omp_comm have access to
    158:     physically shared memory. Rank 0 of each omp_comm is called an OMP master, and
    159:     others are called slaves. OMP Masters make up a new comm called omp_master_comm,
    160:     which is usually passed to third party libraries.
    161:    ==================================================================================*/

    163:   /* fetch the stored shared memory communicator */
    164:   PetscCall(PetscShmCommGet(petsc_comm, &pshmcomm));
    165:   PetscCall(PetscShmCommGetMpiShmComm(pshmcomm, &shm_comm));

    167:   PetscCallMPI(MPI_Comm_rank(shm_comm, &shm_rank));
    168:   PetscCallMPI(MPI_Comm_size(shm_comm, &shm_comm_size));

    170:   /* PETSc decides nthreads, which is the smaller of shm_comm_size or cores per package(socket) */
    171:   if (nthreads == -1) {
    172:     num_packages = hwloc_get_nbobjs_by_type(ctrl->topology, HWLOC_OBJ_PACKAGE) <= 0 ? 1 : hwloc_get_nbobjs_by_type(ctrl->topology, HWLOC_OBJ_PACKAGE);
    173:     num_cores    = hwloc_get_nbobjs_by_type(ctrl->topology, HWLOC_OBJ_CORE) <= 0 ? 1 : hwloc_get_nbobjs_by_type(ctrl->topology, HWLOC_OBJ_CORE);
    174:     nthreads     = num_cores / num_packages;
    175:     if (nthreads > shm_comm_size) nthreads = shm_comm_size;
    176:   }

    178:   PetscCheck(nthreads >= 1 && nthreads <= shm_comm_size, petsc_comm, PETSC_ERR_ARG_OUTOFRANGE, "number of OpenMP threads %" PetscInt_FMT " can not be < 1 or > the MPI shared memory communicator size %d", nthreads, shm_comm_size);
    179:   if (shm_comm_size % nthreads) PetscCall(PetscPrintf(petsc_comm, "Warning: number of OpenMP threads %" PetscInt_FMT " is not a factor of the MPI shared memory communicator size %d, which may cause load-imbalance!\n", nthreads, shm_comm_size));

    181:   /* split shm_comm into a set of omp_comms with each of size nthreads. Ex., if
    182:      shm_comm_size=16, nthreads=8, then ranks 0~7 get color 0 and ranks 8~15 get
    183:      color 1. They are put in two omp_comms. Note that petsc_ranks may or may not
    184:      be consecutive in a shm_comm, but shm_ranks always run from 0 to shm_comm_size-1.
    185:      Use 0 as key so that rank ordering wont change in new comm.
    186:    */
    187:   color = shm_rank / nthreads;
    188:   PetscCallMPI(MPI_Comm_split(shm_comm, color, 0 /*key*/, &ctrl->omp_comm));

    190:   /* put rank 0's in omp_comms (i.e., master ranks) into a new comm - omp_master_comm */
    191:   PetscCallMPI(MPI_Comm_rank(ctrl->omp_comm, &omp_rank));
    192:   if (!omp_rank) {
    193:     ctrl->is_omp_master = PETSC_TRUE; /* master */
    194:     color               = 0;
    195:   } else {
    196:     ctrl->is_omp_master = PETSC_FALSE;   /* slave */
    197:     color               = MPI_UNDEFINED; /* to make slaves get omp_master_comm = MPI_COMM_NULL in MPI_Comm_split */
    198:   }
    199:   PetscCallMPI(MPI_Comm_split(petsc_comm, color, 0 /*key*/, &ctrl->omp_master_comm));

    201:   /*=================================================================================
    202:     Each omp_comm has a pthread_barrier_t in its shared memory, which is used to put
    203:     slave ranks in sleep and idle their CPU, so that the master can fork OMP threads
    204:     and run them on the idle CPUs.
    205:    ==================================================================================*/
    206:   PetscCall(PetscOmpCtrlCreateBarrier(ctrl));

    208:   /*=================================================================================
    209:     omp master logs its cpu binding (i.e., cpu set) and computes a new binding that
    210:     is the union of the bindings of all ranks in the omp_comm
    211:     =================================================================================*/

    213:   ctrl->cpuset = hwloc_bitmap_alloc();
    214:   PetscCheck(ctrl->cpuset, PETSC_COMM_SELF, PETSC_ERR_LIB, "hwloc_bitmap_alloc() failed");
    215:   PetscCallExternal(hwloc_get_cpubind, ctrl->topology, ctrl->cpuset, HWLOC_CPUBIND_PROCESS);

    217:   /* hwloc main developer said they will add new APIs hwloc_bitmap_{nr,to,from}_ulongs in 2.1 to help us simplify the following bitmap pack/unpack code */
    218:   nr_cpu_ulongs = (hwloc_bitmap_last(hwloc_topology_get_topology_cpuset(ctrl->topology)) + sizeof(unsigned long) * 8) / sizeof(unsigned long) / 8;
    219:   PetscCall(PetscMalloc1(nr_cpu_ulongs, &cpu_ulongs));
    220:   if (nr_cpu_ulongs == 1) {
    221:     cpu_ulongs[0] = hwloc_bitmap_to_ulong(ctrl->cpuset);
    222:   } else {
    223:     for (PetscMPIInt i = 0; i < nr_cpu_ulongs; i++) cpu_ulongs[i] = hwloc_bitmap_to_ith_ulong(ctrl->cpuset, (unsigned)i);
    224:   }

    226:   PetscCallMPI(MPI_Reduce(ctrl->is_omp_master ? MPI_IN_PLACE : cpu_ulongs, cpu_ulongs, nr_cpu_ulongs, MPI_UNSIGNED_LONG, MPI_BOR, 0, ctrl->omp_comm));

    228:   if (ctrl->is_omp_master) {
    229:     ctrl->omp_cpuset = hwloc_bitmap_alloc();
    230:     PetscCheck(ctrl->omp_cpuset, PETSC_COMM_SELF, PETSC_ERR_LIB, "hwloc_bitmap_alloc() failed");
    231:     if (nr_cpu_ulongs == 1) {
    232: #if HWLOC_API_VERSION >= 0x00020000
    233:       PetscCallExternal(hwloc_bitmap_from_ulong, ctrl->omp_cpuset, cpu_ulongs[0]);
    234: #else
    235:       hwloc_bitmap_from_ulong(ctrl->omp_cpuset, cpu_ulongs[0]);
    236: #endif
    237:     } else {
    238:       for (PetscMPIInt i = 0; i < nr_cpu_ulongs; i++) {
    239: #if HWLOC_API_VERSION >= 0x00020000
    240:         PetscCallExternal(hwloc_bitmap_set_ith_ulong, ctrl->omp_cpuset, (unsigned)i, cpu_ulongs[i]);
    241: #else
    242:         hwloc_bitmap_set_ith_ulong(ctrl->omp_cpuset, (unsigned)i, cpu_ulongs[i]);
    243: #endif
    244:       }
    245:     }
    246:   }
    247:   PetscCall(PetscFree(cpu_ulongs));
    248:   *pctrl = ctrl;
    249:   PetscFunctionReturn(PETSC_SUCCESS);
    250: }

    252: /*@C
    253:   PetscOmpCtrlDestroy - destroy the PETSc OpenMP controller

    255:   Input Parameter:
    256: . pctrl - a PETSc OpenMP controller

    258:   Level: developer

    260: .seealso: `PetscOmpCtrlCreate()`, `PetscOmpCtrlGetOmpComms()`, `PetscOmpCtrlBarrier()`, `PetscOmpCtrlOmpRegionOnMasterBegin()`, `PetscOmpCtrlOmpRegionOnMasterEnd()`
    261: @*/
    262: PetscErrorCode PetscOmpCtrlDestroy(PetscOmpCtrl *pctrl)
    263: {
    264:   PetscOmpCtrl ctrl = *pctrl;

    266:   PetscFunctionBegin;
    267:   hwloc_bitmap_free(ctrl->cpuset);
    268:   hwloc_topology_destroy(ctrl->topology);
    269:   PetscCall(PetscOmpCtrlDestroyBarrier(ctrl));
    270:   PetscCallMPI(MPI_Comm_free(&ctrl->omp_comm));
    271:   if (ctrl->is_omp_master) {
    272:     hwloc_bitmap_free(ctrl->omp_cpuset);
    273:     PetscCallMPI(MPI_Comm_free(&ctrl->omp_master_comm));
    274:   }
    275:   PetscCall(PetscFree(ctrl));
    276:   PetscFunctionReturn(PETSC_SUCCESS);
    277: }

    279: /*@C
    280:   PetscOmpCtrlGetOmpComms - Get MPI communicators from a PETSc OMP controller

    282:   Input Parameter:
    283: . ctrl - a PETSc OMP controller

    285:   Output Parameters:
    286: + omp_comm        - a communicator that includes a master rank and slave ranks where master spawns threads
    287: . omp_master_comm - on master ranks, return a communicator that include master ranks of each omp_comm;
    288:                     on slave ranks, `MPI_COMM_NULL` will be return in reality.
    289: - is_omp_master   - true if the calling process is an OMP master rank.

    291:   Note:
    292:   Any output parameter can be `NULL`. The parameter is just ignored.

    294:   Level: developer

    296: .seealso: `PetscOmpCtrlCreate()`, `PetscOmpCtrlDestroy()`, `PetscOmpCtrlBarrier()`, `PetscOmpCtrlOmpRegionOnMasterBegin()`, `PetscOmpCtrlOmpRegionOnMasterEnd()`
    297: @*/
    298: PetscErrorCode PetscOmpCtrlGetOmpComms(PetscOmpCtrl ctrl, MPI_Comm *omp_comm, MPI_Comm *omp_master_comm, PetscBool *is_omp_master)
    299: {
    300:   PetscFunctionBegin;
    301:   if (omp_comm) *omp_comm = ctrl->omp_comm;
    302:   if (omp_master_comm) *omp_master_comm = ctrl->omp_master_comm;
    303:   if (is_omp_master) *is_omp_master = ctrl->is_omp_master;
    304:   PetscFunctionReturn(PETSC_SUCCESS);
    305: }

    307: /*@C
    308:   PetscOmpCtrlBarrier - Do barrier on MPI ranks in omp_comm contained by the PETSc OMP controller (to let slave ranks free their CPU)

    310:   Input Parameter:
    311: . ctrl - a PETSc OMP controller

    313:   Notes:
    314:   This is a pthread barrier on MPI ranks. Using `MPI_Barrier()` instead is conceptually correct. But MPI standard does not
    315:   require processes blocked by `MPI_Barrier()` free their CPUs to let other processes progress. In practice, to minilize latency,
    316:   MPI ranks stuck in `MPI_Barrier()` keep polling and do not free CPUs. In contrast, pthread_barrier has this requirement.

    318:   A code using `PetscOmpCtrlBarrier()` would be like this,
    319: .vb
    320:   if (is_omp_master) {
    321:     PetscOmpCtrlOmpRegionOnMasterBegin(ctrl);
    322:     Call the library using OpenMP
    323:     PetscOmpCtrlOmpRegionOnMasterEnd(ctrl);
    324:   }
    325:   PetscOmpCtrlBarrier(ctrl);
    326: .ve

    328:   Level: developer

    330: .seealso: `PetscOmpCtrlOmpRegionOnMasterBegin()`, `PetscOmpCtrlOmpRegionOnMasterEnd()`, `PetscOmpCtrlCreate()`, `PetscOmpCtrlDestroy()`
    331: @*/
    332: PetscErrorCode PetscOmpCtrlBarrier(PetscOmpCtrl ctrl)
    333: {
    334:   int err;

    336:   PetscFunctionBegin;
    337:   err = pthread_barrier_wait(ctrl->barrier);
    338:   PetscCheck(!err || err == PTHREAD_BARRIER_SERIAL_THREAD, PETSC_COMM_SELF, PETSC_ERR_LIB, "pthread_barrier_wait failed within PetscOmpCtrlBarrier with return code %d", err);
    339:   PetscFunctionReturn(PETSC_SUCCESS);
    340: }

    342: /*@C
    343:   PetscOmpCtrlOmpRegionOnMasterBegin - Mark the beginning of an OpenMP library call on master ranks

    345:   Input Parameter:
    346: . ctrl - a PETSc OMP controller

    348:   Note:
    349:   Only master ranks can call this function. Call `PetscOmpCtrlGetOmpComms()` to know if this is a master rank.
    350:   This function changes CPU binding of master ranks and nthreads-var of OpenMP runtime

    352:   Level: developer

    354: .seealso: `PetscOmpCtrlOmpRegionOnMasterEnd()`, `PetscOmpCtrlCreate()`, `PetscOmpCtrlDestroy()`, `PetscOmpCtrlBarrier()`
    355: @*/
    356: PetscErrorCode PetscOmpCtrlOmpRegionOnMasterBegin(PetscOmpCtrl ctrl)
    357: {
    358:   PetscFunctionBegin;
    359:   PetscCallExternal(hwloc_set_cpubind, ctrl->topology, ctrl->omp_cpuset, HWLOC_CPUBIND_PROCESS);
    360:   omp_set_num_threads(ctrl->omp_comm_size); /* may override the OMP_NUM_THREAD env var */
    361:   PetscFunctionReturn(PETSC_SUCCESS);
    362: }

    364: /*@C
    365:   PetscOmpCtrlOmpRegionOnMasterEnd - Mark the end of an OpenMP library call on master ranks

    367:   Input Parameter:
    368: . ctrl - a PETSc OMP controller

    370:   Note:
    371:   Only master ranks can call this function. Call `PetscOmpCtrlGetOmpComms()` to know if this is a master rank.
    372:   This function restores the CPU binding of master ranks and set and nthreads-var of OpenMP runtime to 1.

    374:   Level: developer

    376: .seealso: `PetscOmpCtrlOmpRegionOnMasterBegin()`, `PetscOmpCtrlCreate()`, `PetscOmpCtrlDestroy()`, `PetscOmpCtrlBarrier()`
    377: @*/
    378: PetscErrorCode PetscOmpCtrlOmpRegionOnMasterEnd(PetscOmpCtrl ctrl)
    379: {
    380:   PetscFunctionBegin;
    381:   PetscCallExternal(hwloc_set_cpubind, ctrl->topology, ctrl->cpuset, HWLOC_CPUBIND_PROCESS);
    382:   omp_set_num_threads(1);
    383:   PetscFunctionReturn(PETSC_SUCCESS);
    384: }

    386: #undef USE_MMAP_ALLOCATE_SHARED_MEMORY