Merge pull request #113 from nbelakovski/add_callback

Add callbacks; thank @nbelakovski  and @jschueller !

.github/actions/spelling/allow.txt

@@ -45,6 +45,7 @@ BQPGASIM
 BROWNAL
 Bindel
 Broyden
+CCALLBACK
 CGRAD
 CHANDHEQ
 CHCKTST
@@ -2048,8 +2049,6 @@ COBJCON
 cobjfun
 cobjfuncon
 constrc
-evalcobj
-evalcobjcon
 execstack
 FUNPTR
 PROCPOINTER
@@ -2136,3 +2135,6 @@ orthtol
 nouninit
 libgfortran
 chocolatey
+fcn
+BINDIR
+cmdfile

.github/workflows/cmake.yml

@@ -83,6 +83,9 @@ jobs:
           ssh-key: ${{ secrets.SSH_PRIVATE_KEY_ACT }} # This forces checkout to use SSH, not HTTPS
           submodules: recursive
 
+      - name: Miscellaneous setup
+        run: bash .github/scripts/misc_setup
+
       - name: Install Ninja / Ubuntu
         if: ${{ matrix.os == 'ubuntu-latest' }}
         run: sudo apt update && sudo apt install ninja-build
@@ -116,17 +119,18 @@ jobs:
         run: |
           cmake --version
           cmake -G Ninja -DCMAKE_BUILD_TYPE=RelWithDebInfo -DCMAKE_INSTALL_PREFIX=. -LAH -DCMAKE_C_FLAGS="${{ matrix.toolchain.cflags }}" -DCMAKE_Fortran_FLAGS="${{ matrix.toolchain.fflags }}" .
-          cmake --build . --target install --parallel 4
-          cmake --build . --target tests --parallel 4
-          ctest --output-on-failure -V -j4 -E stress
+          cmake --build . --target install
+          cmake --build . --target tests
+          ctest --output-on-failure -V -E stress
         env:
           FC: ${{ steps.setup-fortran.outputs.fc }}
         shell: bash
 
       - name: Stress test
         if: ${{ github.event_name == 'schedule' || github.event.inputs.stress-test == 'true' }}
         run: |
-          ctest --output-on-failure -V -j4 -R stress
+          ctest --output-on-failure -V -R stress
+        shell: bash
 
 
   cmake-other:
@@ -156,6 +160,9 @@ jobs:
           ssh-key: ${{ secrets.SSH_PRIVATE_KEY_ACT }} # This forces checkout to use SSH, not HTTPS
           submodules: recursive
 
+      - name: Miscellaneous setup
+        run: bash .github/scripts/misc_setup
+
       - name: Install AOCC
         if: ${{ matrix.toolchain.compiler == 'aflang' }}
         run: bash .github/scripts/install_aocc
@@ -171,17 +178,19 @@ jobs:
       - name: Build
         run: |
           cmake -DCMAKE_BUILD_TYPE=RelWithDebInfo -DCMAKE_INSTALL_PREFIX=. -LAH -DCMAKE_C_FLAGS="${{ matrix.toolchain.cflags }}" -DCMAKE_Fortran_FLAGS="${{ matrix.toolchain.fflags }}" .
-          cmake --build . --target install --parallel 4
-          cmake --build . --target tests --parallel 4
+          cmake --build . --target install
+          cmake --build . --target tests
           # cobyla test does not pass on AOCC: https://github.com/libprima/prima/issues/41
-          ctest --output-on-failure -V -j4 -E "stress|cobyla"
+          ctest --output-on-failure -V -E "stress|cobyla"
+        shell: bash
         env:
           FC: ${{ matrix.toolchain.compiler }}
 
       - name: Stress test
         if: ${{ github.event_name == 'schedule' || github.event.inputs.stress-test == 'true' }}
         run: |
-          ctest --output-on-failure -V -j4 -R stress -E cobyla
+          ctest --output-on-failure -V -R stress -E cobyla
+        shell: bash
 
 
   # The following job check whether the tests were successful or cancelled due to timeout.

CMakeLists.txt

@@ -36,6 +36,15 @@ if (PRIMA_HEAP_ARRAYS)
   endif ()
 endif ()
 
+# For running tests with gdb. $_exitcode == -1 means the program ran without exiting
+# normally, and in this case we want to show a stack trace
+file(WRITE ${CMAKE_BINARY_DIR}/cmdfile.gdb "init-if-undefined $_exitcode = -1
+run
+if $_exitcode == -1
+  where
+end
+quit $_exitcode")
+
 option(PRIMA_ENABLE_EXAMPLES "build examples by default" OFF)
 add_custom_target (examples)
 enable_testing ()

c/CMakeLists.txt

@@ -6,6 +6,7 @@ if (WIN32)
   set_target_properties(primac PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/bin)
 endif()
 
+
 target_include_directories (primac PUBLIC
   $<INSTALL_INTERFACE:include>
   $<BUILD_INTERFACE:${CMAKE_CURRENT_SOURCE_DIR}/include>
@@ -35,7 +36,21 @@ macro (prima_add_c_test name)
   if (WIN32)
     set_target_properties(example_${name}_c_exe PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/bin)
   endif()
+
+  # Outside of CI we don't want to force people to run examples with gdb, so we test the executables by themselves.
+  # We want these to run in CI as well, because sometimes running with gdb masks an error, so we set them up
+  # before we set up the examples for CI
   add_test (NAME example_${name}_c COMMAND example_${name}_c_exe)
+
+  # Within CI, we'd like to run with gdb so that if there's a segfault the logs will have a stacktrace we can use to investigate.
+  # Of course this can be run locally as well if you define CI in your environment.
+  if(NOT APPLE AND UNIX AND DEFINED ENV{CI})  # Apple security policy will not allow running gdb in CI
+    add_test (NAME example_${name}_c_with_gdb COMMAND gdb -batch --command=${CMAKE_BINARY_DIR}/cmdfile.gdb example_${name}_c_exe)
+  elseif(WIN32 AND DEFINED ENV{CI})
+    # For Windows we need to provide the full path to the executable since it is installed to a different directory
+    add_test (NAME example_${name}_c_with_gdb COMMAND gdb -batch --command=${CMAKE_BINARY_DIR}/cmdfile.gdb ${CMAKE_BINARY_DIR}/${CMAKE_INSTALL_BINDIR}/example_${name}_c_exe.exe)
+  endif()
+
   add_dependencies(examples example_${name}_c_exe)
 endmacro ()
 

c/bobyqa_c.f90

@@ -13,9 +13,10 @@ module bobyqa_c_mod
 contains
 
 
-subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, ftarget, maxfun, npt, iprint, info) bind(C)
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR
-use, non_intrinsic :: cintrf_mod, only : COBJ
+subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, &
+    & ftarget, maxfun, npt, iprint, callback_ptr, info) bind(C)
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR, C_ASSOCIATED, C_F_PROCPOINTER
+use, non_intrinsic :: cintrf_mod, only : COBJ, CCALLBACK
 use, non_intrinsic :: consts_mod, only : RP, IK
 use, non_intrinsic :: bobyqa_mod, only : bobyqa
 implicit none
@@ -36,6 +37,7 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 integer(C_INT), intent(in), value :: maxfun
 integer(C_INT), intent(in), value :: npt
 integer(C_INT), intent(in), value :: iprint
+type(C_FUNPTR), intent(in), value :: callback_ptr
 integer(C_INT), intent(out) :: info
 
 ! Local variables
@@ -51,6 +53,12 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 real(RP) :: x_loc(n)
 real(RP) :: xl_loc(n)
 real(RP) :: xu_loc(n)
+! The initialization to null is necessary to avoid a bug with the newer Intel compiler ifx.
+! See details here: https://fortran-lang.discourse.group/t/strange-issue-with-ifx-compiler-and-assume-recursion/7013
+! The bug was observed in all versions of ifx up to 2024.0.1. Once this bug is fixed we should remove the
+! initialization to null because it implies the 'save' attribute, which is undesirable.
+procedure(COBJ), pointer :: obj_ptr => null()
+procedure(CCALLBACK), pointer :: cb_ptr => null()
 
 ! Read the inputs and convert them to the Fortran side types
 x_loc = real(x, kind(x_loc))
@@ -62,10 +70,20 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 maxfun_loc = int(maxfun, kind(maxfun_loc))
 npt_loc = int(npt, kind(npt_loc))
 iprint_loc = int(iprint, kind(iprint_loc))
+call C_F_PROCPOINTER(cobj_ptr, obj_ptr)
 
 ! Call the Fortran code
-call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
-    & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, info=info_loc)
+if (C_ASSOCIATED(callback_ptr)) then
+    ! If a C callback function is provided, we convert it to a Fortran procedure pointer and capture
+    ! that pointer in the closure below.
+    call C_F_PROCPOINTER(callback_ptr, cb_ptr)
+    ! We then provide the closure to the algorithm.
+    call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
+        & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, callback_fcn=callback_fcn, info=info_loc)
+else
+    call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
+        & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, info=info_loc)
+end if
 
 ! Write the outputs
 x = real(x_loc, kind(x))
@@ -79,16 +97,99 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 ! This subroutine defines `calfun` using the C function pointer with an internal subroutine.
 ! This allows to avoid passing the C function pointer by a module variable, which is thread-unsafe.
 ! A possible security downside is that the compiler must allow for an executable stack.
+! This subroutine is identical across 4 out of 5 algorithms; COBYLA requires a slightly different
+! signature.
 !--------------------------------------------------------------------------------------------------!
 subroutine calfun(x_sub, f_sub)
+use, intrinsic :: iso_c_binding, only : C_DOUBLE
 use, non_intrinsic :: consts_mod, only : RP
-use, non_intrinsic :: cintrf_mod, only : evalcobj
 implicit none
-real(RP), intent(in) :: x_sub(:)
+real(RP), intent(in) :: x_sub(:) ! We name some variables _sub to avoid masking the parent variables
 real(RP), intent(out) :: f_sub
-call evalcobj(cobj_ptr, data_ptr, x_sub, f_sub)
+
+! Local variables
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+
+! Read the inputs and convert them to the types specified in COBJ
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+
+! Call the C objective function
+call obj_ptr(x_sub_loc, f_sub_loc, data_ptr)
+
+! Write the output
+f_sub = real(f_sub_loc, kind(f_sub))
+
 end subroutine calfun
 
+
+!--------------------------------------------------------------------------------------------------!
+! This subroutine defines `callback_fcn` using the C function pointer with an internal subroutine.
+! This allows to avoid passing the C function pointer by a module variable, which is thread-unsafe.
+! A possible security downside is that the compiler must allow for an executable stack.
+! This subroutine is identical across all 5 algorithms.
+!--------------------------------------------------------------------------------------------------!
+subroutine callback_fcn(x_sub, f_sub, nf_sub, tr, cstrv_sub, nlconstr_sub, terminate)
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_BOOL
+use, non_intrinsic :: consts_mod, only : RP, IK
+use, non_intrinsic :: memory_mod, only : safealloc
+implicit none
+real(RP), intent(in) :: x_sub(:) ! We name some variables _sub to avoid masking the parent variables
+real(RP), intent(in) :: f_sub
+integer(IK), intent(in) :: nf_sub
+integer(IK), intent(in) :: tr
+real(RP), intent(in), optional :: cstrv_sub
+real(RP), intent(in), optional :: nlconstr_sub(:)
+logical, intent(out), optional :: terminate
+
+! Local variables
+integer(C_INT) :: n_sub_loc
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+integer(C_INT) :: nf_sub_loc
+integer(C_INT) :: tr_loc
+real(C_DOUBLE) :: cstrv_sub_loc
+integer(C_INT) :: m_nlconstr
+real(C_DOUBLE), allocatable :: nlconstr_sub_loc(:)
+logical(C_BOOL) :: terminate_loc
+
+! Read the inputs and convert them to the types specified in CCALLBACK
+n_sub_loc = size(x_sub)
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+f_sub_loc = real(f_sub, kind(f_sub_loc))
+nf_sub_loc = int(nf_sub, kind(nf_sub_loc))
+tr_loc = int(tr, kind(tr_loc))
+
+! Set the constraint violation to a sensible default value if it is not provided.
+if (present(cstrv_sub)) then
+    cstrv_sub_loc = real(cstrv_sub, kind(cstrv_sub_loc))
+else
+    cstrv_sub_loc = 0.0_C_DOUBLE
+end if
+
+! Set the nonlinear constraints to a sensible default value if it is not provided.
+if (present(nlconstr_sub)) then
+    m_nlconstr = int(size(nlconstr_sub), C_INT)
+    call safealloc(nlconstr_sub_loc, int(m_nlconstr, IK))
+    nlconstr_sub_loc = real(nlconstr_sub, kind(nlconstr_sub_loc))
+else
+    m_nlconstr = 0_C_INT
+    nlconstr_sub_loc = [real(C_DOUBLE) ::]
+end if
+
+! Call the C callback function
+call cb_ptr(n_sub_loc, x_sub_loc, f_sub_loc, nf_sub_loc, tr_loc, cstrv_sub_loc, m_nlconstr, nlconstr_sub_loc, terminate_loc)
+
+! Write the output
+if ( present(terminate) ) then
+    terminate = logical(terminate_loc, kind(terminate))
+end if
+
+! Deallocate resources
+if (allocated(nlconstr_sub_loc)) deallocate(nlconstr_sub_loc)
+
+end subroutine callback_fcn
+
 end subroutine bobyqa_c
 
 

c/cintrf.f90

@@ -7,7 +7,7 @@ module cintrf_mod
 
 implicit none
 private
-public :: COBJ, COBJCON, evalcobj, evalcobjcon
+public :: COBJ, COBJCON, CCALLBACK
 
 
 abstract interface
@@ -31,66 +31,23 @@ subroutine COBJCON(x, f, constr, data_ptr) bind(c)
     type(C_PTR), intent(in), value :: data_ptr
     end subroutine COBJCON
 
-end interface
-
-
-contains
-
-
-subroutine evalcobj(cobj_ptr, data_ptr, x, f)
-use, non_intrinsic :: consts_mod, only : RP
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_FUNPTR, C_F_PROCPOINTER, C_PTR
-implicit none
-type(C_FUNPTR), intent(in) :: cobj_ptr
-type(C_PTR), intent(in), value :: data_ptr
-real(RP), intent(in) :: x(:)
-real(RP), intent(out) :: f
-
-! Local variables
-procedure(COBJ), pointer :: obj_ptr
-real(C_DOUBLE) :: x_loc(size(x))
-real(C_DOUBLE) :: f_loc
-
-! Read the inputs and convert them to the types specified in COBJ
-x_loc = real(x, kind(x_loc))
-call C_F_PROCPOINTER(cobj_ptr, obj_ptr)
-
-! Call the C objective function
-call obj_ptr(x_loc, f_loc, data_ptr)
-
-! Write the output
-f = real(f_loc, kind(f))
-
-end subroutine evalcobj
-
-
-subroutine evalcobjcon(cobjcon_ptr, data_ptr, x, f, constr)
-use, non_intrinsic :: consts_mod, only : RP
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_FUNPTR, C_F_PROCPOINTER, C_PTR
-implicit none
-type(C_FUNPTR), intent(in) :: cobjcon_ptr
-type(C_PTR), intent(in), value :: data_ptr
-real(RP), intent(in) :: x(:)
-real(RP), intent(out) :: f
-real(RP), intent(out) :: constr(:)
-
-! Local variables
-procedure(COBJCON), pointer :: objcon_ptr
-real(C_DOUBLE) :: x_loc(size(x))
-real(C_DOUBLE) :: f_loc
-real(C_DOUBLE) :: constr_loc(size(constr))
-
-! Read the inputs and convert them to the types specified in COBJCON
-x_loc = real(x, kind(x_loc))
-call C_F_PROCPOINTER(cobjcon_ptr, objcon_ptr)
+    subroutine CCALLBACK(n, x, f, nf, tr, cstrv, m_nlcon, nlconstr, terminate) bind(c)
+    use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_BOOL, C_INT
+    implicit none
+    integer(C_INT), intent(in), value :: n
+    ! We cannot use assumed-shape arrays for C interoperability
+    real(C_DOUBLE), intent(in) :: x(*)
+    real(C_DOUBLE), intent(in), value :: f
+    integer(C_INT), intent(in), value :: nf
+    integer(C_INT), intent(in), value :: tr
+    real(C_DOUBLE), intent(in), value :: cstrv
+    integer(C_INT), intent(in), value :: m_nlcon
+    real(C_DOUBLE), intent(in) :: nlconstr(*)
+    logical(C_BOOL), intent(out) :: terminate
+    end subroutine CCALLBACK
 
-! Call the C objective function
-call objcon_ptr(x_loc, f_loc, constr_loc, data_ptr)
 
-! Write the output
-f = real(f_loc, kind(f))
-constr = real(constr_loc, kind(constr))
+end interface
 
-end subroutine evalcobjcon
 
 end module cintrf_mod