diff --git a/app/native-multi-image.F90 b/app/native-multi-image.F90 index fab7fab5..f42660de 100644 --- a/app/native-multi-image.F90 +++ b/app/native-multi-image.F90 @@ -34,11 +34,18 @@ program native_multi_image #endif #ifndef HAVE_CO_BROADCAST #define HAVE_CO_BROADCAST HAVE_COLLECTIVES +#endif +#ifndef HAVE_TEAM +#define HAVE_TEAM 1 #endif USE, INTRINSIC :: ISO_FORTRAN_ENV integer :: me, ni, peer, tmp character(len=5) :: c +# if HAVE_TEAM + integer :: team_id + type(TEAM_TYPE) :: subteam, res +# endif me = THIS_IMAGE() ni = NUM_IMAGES() @@ -46,6 +53,16 @@ program native_multi_image write(*,'(A,I1,A,I1,A)') "Hello, world! From image ", me, " of ", ni, " images" +# if SET_EXCEPTIONS + block + ! deliberately trigger IEEE arithmetic exceptions: INEXACT and UNDERFLOW + real :: r + r = 1e-30 + r = r + r * r + write (*,*) r + end block +# endif + # if HAVE_SYNC_ALL call status("Testing SYNC ALL...") call sync_all @@ -91,6 +108,24 @@ program native_multi_image call CO_BROADCAST(c,1) # endif +# if HAVE_TEAM + call status("Testing TEAMS...") + res = GET_TEAM(CURRENT_TEAM) + res = GET_TEAM(INITIAL_TEAM) + res = GET_TEAM() + write(*,'(A,I3)') "Initial team number is ", TEAM_NUMBER() + + team_id = merge(1, 2, me <= (ni+1)/2) + + FORM TEAM(team_id, subteam) + SYNC TEAM(subteam) + CHANGE TEAM(subteam) + write(*,'(A,I3,A,I3,A,I3)') 'Inside CHANGE TEAM construct: ', THIS_IMAGE(), ' of ', NUM_IMAGES(), ' in team number ', TEAM_NUMBER() + END TEAM + call sync_all + write(*,'(A,I3)') "After END TEAM statement, TEAM_NUMBER() is ", TEAM_NUMBER() +# endif + call sync_all write(*,'(A,I1,A,I1,A)') "Goodbye from image ", me, " of ", ni, " images" diff --git a/src/caffeine/caffeine.c b/src/caffeine/caffeine.c index 1e64977d..54589b3f 100644 --- a/src/caffeine/caffeine.c +++ b/src/caffeine/caffeine.c @@ -5,6 +5,8 @@ #include #include #include +#include +#include #include #include #include @@ -34,6 +36,22 @@ typedef uint8_t byte; static void event_init(void); static void atomic_init(void); +// --------------------------------------------------- +// Floating-point exception support + +#ifndef IEEE_FE_MASK +#define IEEE_FE_MASK FE_INEXACT +#endif +static fexcept_t fe_flag_save; +void caf_fe_save(void) { + fegetexceptflag(&fe_flag_save, IEEE_FE_MASK); +} +void caf_fe_restore(void) { + fesetexceptflag(&fe_flag_save, IEEE_FE_MASK); +} +#define CHECK_INEXACT() \ + printf("%3i: inexact flag = %s\n",__LINE__,fetestexcept(FE_INEXACT) & FE_INEXACT ? "YES" : "no") + // --------------------------------------------------- int caf_this_image(gex_TM_t tm) { return gex_TM_QueryRank(tm) + 1; @@ -142,7 +160,14 @@ void caf_allocate_remaining(mspace heap, void** allocated_space, size_t* allocat // nor necessarily the largest open space, but in practice is likely // to work out that way struct mallinfo heap_info = mspace_mallinfo(heap); - *allocated_size = heap_info.keepcost * 0.9f; + + // clang's implementation of nearbyint() raises FE_INEXACT, + // in direct contradiction to its specified purpose. + // Workaround this defect by saving and restoring the FE flags + caf_fe_save(); + *allocated_size = (size_t)nearbyint(heap_info.keepcost * 0.9f); + caf_fe_restore(); + *allocated_space = mspace_memalign(heap, 8, *allocated_size); if (!*allocated_space) // uh-oh, something went wrong.. gasnett_fatalerror("caf_allocate_remaining failed to mspace_memalign(%"PRIuSZ")",