diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4c49e8b50..5482f4e5d 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -122,7 +122,7 @@ jobs: version: latest container: ghcr.io/lfortran/lfortran:latest native_multi_image: true - FFLAGS: --coarray=true -DHAVE_SYNC=0 -DHAVE_COLLECTIVES=0 -DHAVE_TEAM=0 + FFLAGS: --coarray=true -DHAVE_SYNC=0 -DHAVE_COLLECTIVES=0 -DHAVE_TEAM=0 -DHAVE_EVENT_TYPE=0 -DHAVE_LOCK_TYPE=0 -DHAVE_NOTIFY_TYPE=0 - os: ubuntu-22.04 compiler: lfortran @@ -317,7 +317,11 @@ jobs: echo "CXX=clang++" >> "$GITHUB_ENV" fi if [ "${NATIVE_MULTI_IMAGE}" == true ] ; then - echo "FFLAGS=$FFLAGS -fcoarray" >> "$GITHUB_ENV" + if [[ $COMPILER_VERSION == latest ]] ; then + echo "FFLAGS=$FFLAGS -fcoarray -DHAVE_COARRAY -DIGNORE_FAILURES=11" >> "$GITHUB_ENV" + else + echo "FFLAGS=$FFLAGS -fcoarray -DIGNORE_FAILURES=8" >> "$GITHUB_ENV" + fi fi - name: Setup lfortran dependencies and variables diff --git a/app/native-multi-image.F90 b/app/native-multi-image.F90 index f42660de7..d5c028d98 100644 --- a/app/native-multi-image.F90 +++ b/app/native-multi-image.F90 @@ -20,6 +20,7 @@ program native_multi_image #ifndef HAVE_SYNC_IMAGES #define HAVE_SYNC_IMAGES HAVE_SYNC #endif + #ifndef HAVE_COLLECTIVES #define HAVE_COLLECTIVES 1 #endif @@ -35,16 +36,76 @@ program native_multi_image #ifndef HAVE_CO_BROADCAST #define HAVE_CO_BROADCAST HAVE_COLLECTIVES #endif + #ifndef HAVE_TEAM #define HAVE_TEAM 1 #endif +#ifndef HAVE_TEAM_TYPE +#define HAVE_TEAM_TYPE HAVE_TEAM +#endif +#ifndef HAVE_EVENT_TYPE +#define HAVE_EVENT_TYPE 1 +#endif +#ifndef HAVE_LOCK_TYPE +#define HAVE_LOCK_TYPE 1 +#endif +#ifndef HAVE_NOTIFY_TYPE +#define HAVE_NOTIFY_TYPE 1 +#endif +! TYPES_IMPORT_PRIF: compiler imports the real PRIF definition of ISO_FORTRAN_ENV types +#ifndef TYPES_IMPORT_PRIF +#define TYPES_IMPORT_PRIF 0 +#endif + +#ifndef HAVE_COARRAY +#define HAVE_COARRAY 0 +#endif +#ifndef HAVE_MAIN_COARRAY +#define HAVE_MAIN_COARRAY HAVE_COARRAY +#endif +#ifndef HAVE_ALLOC_COARRAY +#define HAVE_ALLOC_COARRAY HAVE_COARRAY +#endif +! Helper macros +#define CHECK_TYPE_COMPLIANCE(subject_type, subject, is_team, min_size) \ + BLOCK ; \ + integer(c_int8_t), allocatable, target :: bytes(:) ; \ + bytes = transfer(subject, bytes) ; \ + call check_type(#subject_type, is_team, min_size, \ + storage_size(subject)/8, bytes); \ + END BLOCK + +! Main program USE, INTRINSIC :: ISO_FORTRAN_ENV - integer :: me, ni, peer, tmp + USE, INTRINSIC :: ISO_C_BINDING, only: c_int8_t + + type :: dummy_team_descriptor + end type + type :: dummy_team_type + type(dummy_team_descriptor), pointer :: info => null() + end type + + integer :: me, ni, peer, tmp, fail_count = 0 character(len=5) :: c # if HAVE_TEAM integer :: team_id type(TEAM_TYPE) :: subteam, res + type(TEAM_TYPE) :: default_team +# endif +# if HAVE_MAIN_COARRAY + integer :: sca_int_1[*] + integer :: sca_int_2[2,*] + integer :: sca_int_3[2,3,*] +# endif +# if HAVE_EVENT_TYPE + type(event_type), target :: default_event[*] +# endif +# if HAVE_NOTIFY_TYPE + type(notify_type), target :: default_notify[*] +# endif +# if HAVE_LOCK_TYPE + type(lock_type), target :: default_lock[*] # endif me = THIS_IMAGE() @@ -109,6 +170,9 @@ program native_multi_image # endif # if HAVE_TEAM +# if HAVE_TEAM_TYPE + CHECK_TYPE_COMPLIANCE(TEAM_TYPE, default_team, .true., 0) +# endif call status("Testing TEAMS...") res = GET_TEAM(CURRENT_TEAM) res = GET_TEAM(INITIAL_TEAM) @@ -126,13 +190,38 @@ program native_multi_image write(*,'(A,I3)') "After END TEAM statement, TEAM_NUMBER() is ", TEAM_NUMBER() # endif +# if HAVE_EVENT_TYPE + CHECK_TYPE_COMPLIANCE(EVENT_TYPE, default_event, .false., 64) +# endif + +# if HAVE_LOCK_TYPE + CHECK_TYPE_COMPLIANCE(LOCK_TYPE, default_lock, .false., 64) +# endif + +# if HAVE_NOTIFY_TYPE + CHECK_TYPE_COMPLIANCE(NOTIFY_TYPE, default_notify, .false., 64) +# endif + + call sync_all + call test_allocatable_coarray + call test_allocatable_coarray + call sync_all write(*,'(A,I1,A,I1,A)') "Goodbye from image ", me, " of ", ni, " images" ! explicit flush for now until we have multi-image stop support call flush_all call sync_all - stop + if (fail_count > 0) then + call status("ERROR: "//tostring(fail_count)//" tests FAILED.") + else + call status("All tests passed.") + end if +#if IGNORE_FAILURES + call status("WARNING: Ignoring "//tostring(IGNORE_FAILURES)//" failures.") + fail_count = MAX(0, fail_count - IGNORE_FAILURES) +#endif + stop fail_count contains subroutine sync_all @@ -148,11 +237,119 @@ subroutine status(str) character(len=*) :: str call flush_all call sync_all - if (THIS_IMAGE() == 1) write(*,*) str + if (THIS_IMAGE() == 1) write(*,'(A)') str call flush_all call sync_all end subroutine + subroutine test_allocatable_coarray() +# if HAVE_ALLOC_COARRAY +# define CHECK_ALLOC(coarray, expect) \ + if (ALLOCATED(coarray) .neqv. expect) then ; \ + if (THIS_IMAGE() == 1) write(*,'(A)') __FILE__//":"//tostring(__LINE__)//": ERROR: " // \ + " ALLOCATED(" // #coarray // ") = " // MERGE("true ","false",ALLOCATED(coarray)) ; \ + fail_count = fail_count + 1 ; \ + end if + + logical, save :: once = .true. + integer, allocatable :: aca_int_1[:] + integer, allocatable :: aca_int_2[:,:] + integer, save, allocatable :: aca_int_3[:,:,:] + CHECK_ALLOC(aca_int_1, .false.) + CHECK_ALLOC(aca_int_2, .false.) + CHECK_ALLOC(aca_int_3, .false.) + if (once) then + once = .false. + call status("Testing ALLOCATABLE coarrays...") + ALLOCATE(aca_int_1[*]) + ALLOCATE(aca_int_2[2,*]) + ALLOCATE(aca_int_3[2,3,*]) + CHECK_ALLOC(aca_int_1, .true.) + CHECK_ALLOC(aca_int_2, .true.) + CHECK_ALLOC(aca_int_3, .true.) + end if +# endif + end subroutine + + function tostring(int) result(res) + integer :: int + character(len=128) :: str + character(len=:), allocatable :: res + write(str, *) int + res = trim(adjustl(str)) + end function + + function hexdump(arr) result(res) + integer(c_int8_t), intent(in) :: arr(:) + character(len=:), allocatable :: res + character(len=4096) :: buf + write(buf, '(*(Z2, 1X))') arr + res = trim(buf) + end function + + subroutine check_type(type_name, is_team, min_size, subject_size, default_bytes) + character(len=*), intent(in) :: type_name + logical, intent(in) :: is_team + integer, intent(in) :: min_size, subject_size + integer(c_int8_t), target, intent(in) :: default_bytes(:) + character(len=:), allocatable :: diag +# if HAVE_TEAM + type(TEAM_TYPE) :: team_var + type(dummy_team_type) :: dummy_team_type_var + integer, parameter :: reference_size = storage_size(dummy_team_type_var)/8 +# endif + + call status("Testing " // type_name // "...") + + if (subject_size /= size(default_bytes)) ERROR STOP "INTERNAL ERROR: representation size mismatch" + + if (is_team) then +# if HAVE_TEAM + ! check size, should be an exact match + if (subject_size == reference_size) then + diag = "pass" + else + diag = "FAIL (should be exactly " // tostring(reference_size) // " bytes)" + fail_count = fail_count + 1 + end if + call status(" Size of " // type_name // ": " // tostring(subject_size) // " bytes ==> " // diag) + + ! check default initialization + dummy_team_type_var = transfer(team_var, dummy_team_type_var) + if (.not. associated(dummy_team_type_var%info)) then + diag = "pass" + else + diag = "FAIL (not default-initialized to null(): " // hexdump(default_bytes)// ")" + fail_count = fail_count + 1 + end if + call status(" Default init of " // type_name // " ==> " // diag) +# endif + else +# if TYPES_IMPORT_PRIF + diag = "(validation skipped)" +# else + ! check size, should not be less than min_size + if (subject_size >= min_size) then + diag = "pass" + else + diag = "FAIL (should be >= " // tostring(min_size) // " bytes)" + fail_count = fail_count + 1 + end if +# endif + call status(" Size of " // type_name // ": " // tostring(subject_size) // " bytes ==> " // diag) + + ! check default initialization + if (all(default_bytes == 0)) then + diag = "pass" + else + diag = "FAIL (non-zero value at byte " // tostring((findloc(default_bytes /= 0, .true., dim=1))) // ": " // & + hexdump(default_bytes) // ")" + fail_count = fail_count + 1 + end if + call status(" Default init of " // type_name // " ==> " // diag) + end if + end subroutine + #else stop "Native multi-image test disabled" #endif diff --git a/test/prif_types_test.F90 b/test/prif_types_test.F90 index 7e8dc5d55..4a7405eb9 100644 --- a/test/prif_types_test.F90 +++ b/test/prif_types_test.F90 @@ -2,8 +2,8 @@ module prif_types_test_m use iso_fortran_env, only: int8 - use iso_c_binding, only: c_ptr - use prif, only: prif_team_type, prif_event_type, prif_notify_type, prif_lock_type, prif_critical_type, prif_coarray_handle + use iso_c_binding, only: c_ptr, c_loc, c_intptr_t + use prif, only: prif_team_type, prif_event_type, prif_notify_type, prif_lock_type, prif_critical_type, prif_coarray_handle, prif_this_image_no_coarray use julienne_m, only: test_description_t, test_diagnosis_t, test_result_t, test_t, string_t, usher & ,operator(.all.), operator(.also.), operator(.equalsExpected.), operator(.greaterThan.), operator(.isAtMost.), operator(//) @@ -45,24 +45,66 @@ function results() result(test_results) type(prif_types_test_t) prif_types_test allocate(test_results, source = prif_types_test%run([ & - test_description_t("having a compliant prif_team_type representation", usher(check_team_type)) & + test_description_t("having a compliant prif_coarray_handle representation", usher(check_coarray_handle)) & + , test_description_t("having a compliant prif_team_type representation", usher(check_team_type)) & , test_description_t("having a compliant prif_event_type representation", usher(check_event_type)) & - , test_description_t("having a compliant prif_lock_type representation", usher(check_lock_type)) & , test_description_t("having a compliant prif_notify_type representation", usher(check_notify_type)) & + , test_description_t("having a compliant prif_lock_type representation", usher(check_lock_type)) & , test_description_t("having a compliant prif_critical_type representation", usher(check_critical_type)) & - , test_description_t("having a compliant prif_coarray_handle representation", usher(check_coarray_handle)) & ])) end function + subroutine report_size(typename,sz, align_cptr) + character(len=*), intent(in) :: typename + integer, intent(in) :: sz + type(c_ptr), intent(in) :: align_cptr(:) + character(len=20) :: typestr + integer :: me, i + integer(c_intptr_t) :: cint, align + call prif_this_image_no_coarray(this_image=me) + if (me == 1) then + typestr = typename + align = 0 + do i=1,size(align_cptr) + cint = transfer(align_cptr(i),cint) + align = ior(align, cint) + end do + align = iand(align, -align) + write(*,'(*(A,I3))') " " // typestr // ": ", sz, " bytes, ", align, "-byte aligned" + end if + end subroutine + + ! declare typename variables in various ways to try and deduce minimum alignment requirement + ! this heuristic might fail to discover the narrowest aligment, but does a reasonable job in practice +# define ALIGN(typename) \ + integer :: aai ; \ + type :: align_check ; \ + integer(int8) :: a_pad ; \ + type(typename) :: t ; \ + end type ; \ + type(align_check), target :: align_arr(256) ; \ + integer(int8) :: a_pad2 ; \ + type(align_check), target :: align_s1 ; \ + integer(int8) :: a_pad3 ; \ + type(typename), target :: align_s2 ; \ + type(typename), target, save :: align_s3 ; \ + a_pad2 = 0 ; a_pad3 = 0 ; aai = a_pad2 + a_pad3 ! avoid unused warnings +# define ALIGN_ARGS [ \ + c_loc(align_s1%t), c_loc(align_s2), c_loc(align_s3), \ + ( c_loc(align_arr(aai)%t), aai = 1,size(align_arr) ) \ + ] + function check_team_type() result(diag) type(test_diagnosis_t) :: diag type(prif_team_type) :: team type(pointer_wrapper_t) :: pointer_wrap type(dummy_t), target :: tgt + ALIGN(prif_team_type) diag = .true. ! size check + call report_size("prif_team_type", storage_size(team)/8, ALIGN_ARGS) ALSO(storage_size(team) .equalsExpected. storage_size(pointer_wrap)) ! default initialization check @@ -76,10 +118,12 @@ function check_event_type() result(diag) type(prif_event_type) :: event integer :: ssz integer(int8), allocatable :: bytes(:) + ALIGN(prif_event_type) diag = .true. ! size check + call report_size("prif_event_type", storage_size(event)/8, ALIGN_ARGS) ssz = storage_size(event) ALSO(ssz .greaterThan. 0) ALSO(ssz .isAtMost. 64*8) @@ -95,10 +139,12 @@ function check_lock_type() result(diag) type(prif_lock_type) :: lock integer :: ssz integer(int8), allocatable :: bytes(:) + ALIGN(prif_lock_type) diag = .true. ! size check + call report_size("prif_lock_type", storage_size(lock)/8, ALIGN_ARGS) ssz = storage_size(lock) ALSO(ssz .greaterThan. 0) ALSO(ssz .isAtMost. 64*8) @@ -114,10 +160,12 @@ function check_notify_type() result(diag) type(prif_notify_type) :: notify integer :: ssz integer(int8), allocatable :: bytes(:) + ALIGN(prif_notify_type) diag = .true. ! size check + call report_size("prif_notify_type", storage_size(notify)/8, ALIGN_ARGS) ssz = storage_size(notify) ALSO(ssz .greaterThan. 0) ALSO(ssz .isAtMost. 64*8) @@ -133,10 +181,12 @@ function check_critical_type() result(diag) type(prif_critical_type) :: critical integer :: ssz integer(int8), allocatable :: bytes(:) + ALIGN(prif_critical_type) diag = .true. ! size check + call report_size("prif_critical_type", storage_size(critical)/8, ALIGN_ARGS) ssz = storage_size(critical) ALSO(ssz .greaterThan. 0) ALSO(ssz .isAtMost. 64*8) @@ -151,10 +201,12 @@ function check_coarray_handle() result(diag) type(test_diagnosis_t) :: diag type(prif_coarray_handle) :: handle type(cptr_wrapper_t) :: cptr_wrap + ALIGN(prif_coarray_handle) diag = .true. ! size check + call report_size("prif_coarray_handle", storage_size(handle)/8, ALIGN_ARGS) ALSO(storage_size(handle) .equalsExpected. storage_size(cptr_wrap)) end function