https://gcc.gnu.org/bugzilla/show_bug.cgi?id=116668
--- Comment #2 from Jordan <jordan4ibanez at gmail dot com> --- (In reply to Andrew Pinski from comment #1) > Can you provide the full source where the ICE happens including all module > sources? > > Also since you got the gfortran from your distro you should read the > internal compiler error message: > See <file:///usr/share/doc/gcc-14/README.Bugs> for instructions. > > > And report this bug to them too. This is going to be a bit lengthy, but of course I will. :) Here are all the modules in this little ecosystem. Please keep in mind, this version is very sloppy and has been fixed in more recent updates. (The C code is last because it binds to it.) FORTRAN CODE HERE: module thread_filo_queue use :: thread_types use :: thread_mutex use, intrinsic :: iso_c_binding implicit none private public :: concurrent_linked_filo_queue public :: queue_data integer(c_int), parameter :: QUEUE_NONE = 0 integer(c_int), parameter :: QUEUE_I32 = 1 integer(c_int), parameter :: QUEUE_I64 = 2 integer(c_int), parameter :: QUEUE_F32 = 3 integer(c_int), parameter :: QUEUE_F64 = 4 integer(c_int), parameter :: QUEUE_BOOL = 5 integer(c_int), parameter :: QUEUE_STRING = 6 integer(c_int), parameter :: QUEUE_GENERIC = 7 type :: queue_data !* Basic types. integer(c_int), pointer :: i32 => null() integer(c_int64_t), pointer :: i64 => null() real(c_float), pointer :: f32 => null() real(c_double), pointer :: f64 => null() logical(c_bool), pointer :: bool => null() !* String. character(len = :, kind = c_char), pointer :: string => null() !* Completely polymorphic. class(*), pointer :: generic => null() !* Designate the type of the element. integer(c_int) :: type = QUEUE_NONE end type queue_data interface queue_data module procedure :: queue_data_constructor end interface queue_data type :: queue_node type(queue_node), pointer :: next => null() type(queue_data), pointer :: data => null() end type queue_node type :: concurrent_linked_filo_queue private type(queue_node), pointer :: head => null() type(queue_node), pointer :: tail => null() type(mutex_rwlock), pointer :: mutex => null() type(c_ptr) :: c_mutex_pointer = c_null_ptr integer(c_int) :: items = 0 contains procedure :: push => concurrent_linked_filo_queue_push procedure :: pop => concurrent_linked_filo_queue_pop procedure :: destroy => concurrent_linked_filo_queue_destroy procedure :: is_empty => concurrent_linked_filo_queue_is_empty procedure :: get_size => concurrent_linked_filo_queue_get_size end type concurrent_linked_filo_queue interface concurrent_linked_filo_queue module procedure :: constructor_concurrent_linked_filo_queue end interface concurrent_linked_filo_queue contains function constructor_concurrent_linked_filo_queue() result(new_queue) implicit none type(concurrent_linked_filo_queue) :: new_queue new_queue%mutex => thread_create_mutex_pointer() new_queue%c_mutex_pointer = c_loc(new_queue%mutex) end function constructor_concurrent_linked_filo_queue !* Push an element into the end of a queue. subroutine concurrent_linked_filo_queue_push(this, generic_pointer) implicit none class(concurrent_linked_filo_queue), intent(inout) :: this type(queue_data), intent(in), pointer :: generic_pointer integer(c_int) :: status type(queue_node), pointer :: new_node status = thread_write_lock(this%c_mutex_pointer) !! BEGIN SAFE OPERATION. if (.not. associated(generic_pointer)) then error stop "[Thread FILO Queue] Error: Received a null pointer." end if allocate(new_node) new_node%data => generic_pointer ! If the head is null, this is the new head. if (.not. associated(this%head)) then this%head => new_node end if ! If we have a tail, it now points to the new node. ! The new node then becomes the tail. if (associated(this%tail)) then this%tail%next => new_node this%tail => new_node else ! If we do not have a tail, the new node is now the tail. this%tail => new_node end if this%items = this%items + 1 !! END SAFE OPERATION. status = thread_unlock_lock(this%c_mutex_pointer) end subroutine concurrent_linked_filo_queue_push !* Pop the first element off the queue. function concurrent_linked_filo_queue_pop(this, generic_pointer_option) result(some) implicit none class(concurrent_linked_filo_queue), intent(inout) :: this class(*), intent(inout), pointer :: generic_pointer_option logical(c_bool) :: some integer(c_int) :: status type(queue_node), pointer :: next_pointer status = thread_write_lock(this%c_mutex_pointer) !! BEGIN SAFE OPERATION. some = .false. generic_pointer_option => null() ! If we have a head, the output will become the head data. ! The head will now be shifted forward, and the old head will be cleaned up. if (associated(this%head)) then some = .true. next_pointer => this%head%next ! First we unshell the data. select case(this%head%data%type) case (QUEUE_NONE) error stop "QUEUE FAILURE!" case (QUEUE_I32) generic_pointer_option => this%head%data%i32 case (QUEUE_I64) generic_pointer_option => this%head%data%i64 case (QUEUE_F32) generic_pointer_option => this%head%data%f32 case (QUEUE_F64) generic_pointer_option => this%head%data%f64 case (QUEUE_BOOL) generic_pointer_option => this%head%data%bool case (QUEUE_STRING) generic_pointer_option => this%head%data%string case (QUEUE_GENERIC) generic_pointer_option => this%head%data%generic end select ! Then we deallocate. deallocate(this%head%data) deallocate(this%head) this%head => next_pointer this%items = this%items - 1 end if !* If the head was pointed to null, we must nullify the tail. if (.not. associated(this%head)) then this%tail => null() end if !! END SAFE OPERATION. status = thread_unlock_lock(this%c_mutex_pointer) end function concurrent_linked_filo_queue_pop !* Destroy all data in a queue. !! This will not destroy the mutex. You are still required to do that. subroutine concurrent_linked_filo_queue_destroy(this) implicit none class(concurrent_linked_filo_queue), intent(inout) :: this type(queue_node), pointer :: current, next integer(c_int) :: status status = thread_write_lock(this%c_mutex_pointer) !! BEGIN SAFE OPERATION. if (associated(this%head)) then current => this%head do next => current%next select case(current%data%type) case (QUEUE_NONE) error stop "QUEUE FAILURE!" case (QUEUE_I32) deallocate(current%data%i32) case (QUEUE_I64) deallocate(current%data%i64) case (QUEUE_F32) deallocate(current%data%f32) case (QUEUE_F64) deallocate(current%data%f64) case (QUEUE_BOOL) deallocate(current%data%bool) case (QUEUE_STRING) deallocate(current%data%string) case (QUEUE_GENERIC) deallocate(current%data%generic) end select deallocate(current%data) deallocate(current) ! Pointing at nothing. if (.not. associated(next)) then exit end if current => next end do end if this%head => null() this%tail => null() this%items = 0 !! END SAFE OPERATION. status = thread_unlock_lock(this%c_mutex_pointer) end subroutine concurrent_linked_filo_queue_destroy function queue_data_constructor(generic) result(new_queue_element_pointer) implicit none type(queue_data), pointer :: new_queue_element_pointer class(*), intent(in), target :: generic character(len = :, kind = c_char), allocatable :: temp allocate(new_queue_element_pointer) select type(generic) type is (integer(c_int)) new_queue_element_pointer%type = QUEUE_I32 allocate(new_queue_element_pointer%i32) new_queue_element_pointer%i32 = generic type is (integer(c_int64_t)) new_queue_element_pointer%type = QUEUE_I64 allocate(new_queue_element_pointer%i64) new_queue_element_pointer%i64 = generic type is (real(c_float)) new_queue_element_pointer%type = QUEUE_F32 allocate(new_queue_element_pointer%f32) new_queue_element_pointer%f32 = generic type is (real(c_double)) new_queue_element_pointer%type = QUEUE_F64 allocate(new_queue_element_pointer%f64) new_queue_element_pointer%f64 = generic type is (logical) new_queue_element_pointer%type = QUEUE_BOOL allocate(new_queue_element_pointer%bool) new_queue_element_pointer%bool = generic type is (character(len = *, kind = c_char)) new_queue_element_pointer%type = QUEUE_STRING ! I am working around a GCC bug. temp = generic associate (string_len => len(temp)) allocate(character(len = string_len, kind = c_char) :: new_queue_element_pointer%string) new_queue_element_pointer%string(1:string_len) = temp(1:string_len) end associate class default !? We will check if this thing is a pointer. !! If it's not, it's going to blow up. new_queue_element_pointer%type = QUEUE_GENERIC new_queue_element_pointer%generic => generic end select end function queue_data_constructor !* Check if the queue is empty. function concurrent_linked_filo_queue_is_empty(this) result(empty) implicit none class(concurrent_linked_filo_queue), intent(inout) :: this logical(c_bool) :: empty integer(c_int) :: status status = thread_write_lock(this%c_mutex_pointer) !! BEGIN SAFE OPERATION. empty = this%items == 0 !! END SAFE OPERATION. status = thread_unlock_lock(this%c_mutex_pointer) end function concurrent_linked_filo_queue_is_empty !* Check number of items in the queue. function concurrent_linked_filo_queue_get_size(this) result(item_count) implicit none class(concurrent_linked_filo_queue), intent(inout) :: this integer(c_int) :: item_count integer(c_int) :: status status = thread_write_lock(this%c_mutex_pointer) !! BEGIN SAFE OPERATION. item_count = this%items !! END SAFE OPERATION. status = thread_unlock_lock(this%c_mutex_pointer) end function concurrent_linked_filo_queue_get_size end module thread_filo_queue module thread_types use, intrinsic :: iso_c_binding implicit none ! Raw thread struct. ! https://ffmpeg.org/doxygen/3.1/os2threads_8h_source.html type, bind(c) :: pthread_t integer(c_int64_t) :: tid = 0_8 type(c_funptr) :: start_routine type(c_ptr) :: arg type(c_ptr) :: result end type pthread_t ! Raw thread configuration. type :: pthread_attr_t integer(1), dimension(:), pointer :: raw_data_pointer => null() end type pthread_attr_t ! A raw thread queue element. type :: thread_queue_element type(c_funptr) :: subroutine_pointer = c_null_funptr type(c_ptr) :: data_to_send = c_null_ptr end type thread_queue_element ! What gets passed into the thread. type :: thread_argument logical(c_bool), pointer :: active_flag => null() type(c_ptr) :: sent_data = c_null_ptr type(c_ptr) :: mutex_pointer = c_null_ptr end type thread_argument ! mutex_rwlock. type :: mutex_rwlock integer(1), dimension(:), pointer :: raw_data_pointer => null() end type mutex_rwlock !* for_p_thread. interface function for_p_thread_get_pthread_attr_t_width() result(data_width) bind(c, name = "for_p_thread_get_pthread_attr_t_width") use, intrinsic :: iso_c_binding implicit none integer(c_int) :: data_width end function function for_p_thread_get_pthread_create_detached_id() result(id) bind(c, name = "for_p_thread_get_pthread_create_detached_id") use, intrinsic :: iso_c_binding implicit none integer(c_int) :: id end function function for_p_thread_get_cpu_threads() result(thread_count) bind(c, name = "for_p_thread_get_cpu_threads") use, intrinsic :: iso_c_binding implicit none integer(c_int) :: thread_count end function for_p_thread_get_cpu_threads function for_p_thread_get_pthread_mutex_t_width() result(data_width) bind(c, name = "for_p_thread_get_pthread_mutex_t_width") use, intrinsic :: iso_c_binding implicit none integer(c_int) :: data_width end function for_p_thread_get_pthread_mutex_t_width function for_p_thread_get_pthread_mutexattr_t_width() result(data_width) bind(c, name = "for_p_thread_get_pthread_mutexattr_t_width") use, intrinsic :: iso_c_binding implicit none integer(c_int) :: data_width end function for_p_thread_get_pthread_mutexattr_t_width end interface end module thread_types module thread_mutex use :: thread_types implicit none public :: thread_write_lock public :: thread_read_lock public :: thread_unlock_lock interface function internal_pthread_rwlock_init(rwlock, attr) result(status) bind(c, name = "pthread_rwlock_init") use, intrinsic :: iso_c_binding implicit none type(c_ptr), intent(in), value :: rwlock type(c_ptr), intent(in), value :: attr integer(c_int) :: status end function internal_pthread_rwlock_init function internal_pthread_rwlock_destroy(rwlock, attr) result(status) bind(c, name = "pthread_rwlock_destroy") use, intrinsic :: iso_c_binding implicit none type(c_ptr), intent(in), value :: rwlock type(c_ptr), intent(in), value :: attr integer(c_int) :: status end function internal_pthread_rwlock_destroy function thread_write_lock(rwlock) result(status) bind(c, name = "pthread_rwlock_wrlock") use, intrinsic :: iso_c_binding implicit none type(c_ptr), intent(in), value :: rwlock integer(c_int) :: status end function thread_write_lock function thread_read_lock(rwlock) result(status) bind(c, name = "pthread_rwlock_rdlock") use, intrinsic :: iso_c_binding implicit none type(c_ptr), intent(in), value :: rwlock integer(c_int) :: status end function thread_read_lock function thread_unlock_lock(rwlock) result(status) bind(c, name = "pthread_rwlock_unlock") use, intrinsic :: iso_c_binding implicit none type(c_ptr), intent(in), value :: rwlock integer(c_int) :: status end function thread_unlock_lock end interface contains !* Create a new mutex pointer. function thread_create_mutex_pointer() result(new_mutex_pointer) implicit none type(mutex_rwlock), pointer :: new_mutex_pointer integer(c_int) :: status allocate(new_mutex_pointer) allocate(new_mutex_pointer%raw_data_pointer(for_p_thread_get_pthread_mutex_t_width())) status = internal_pthread_rwlock_init(c_loc(new_mutex_pointer), c_null_ptr) end function thread_create_mutex_pointer end module thread_mutex C CODE HERE: #include <pthread.h> #include <unistd.h> // This one is for looking up error IDs. // #include <errno.h> // Go through to <errno-base.h> // You can ctrl - click this to get there. // int test = ENOENT; const static int pthread_attr_t_size = sizeof(pthread_attr_t); const static int pthread_mutex_t_size = sizeof(pthread_mutex_t); const static int pthread_mutexattr_t_size = sizeof(pthread_mutexattr_t); // const static int pthread_create_joinable_id = PTHREAD_CREATE_JOINABLE; const static int pthread_create_detached_id = PTHREAD_CREATE_DETACHED; //* Make this portable. int for_p_thread_get_pthread_attr_t_width() { return pthread_attr_t_size; } int for_p_thread_get_pthread_mutex_t_width() { return pthread_mutex_t_size; } int for_p_thread_get_pthread_mutexattr_t_width() { return pthread_mutexattr_t_size; } //* Get the #DEFINE of detach. int for_p_thread_get_pthread_create_detached_id() { return pthread_create_detached_id; } //* Getting the number of available threads. //* You can thank tavianator: https://www.reddit.com/r/C_Programming/comments/6zxnr1/comment/dmzuwt6 int for_p_thread_get_cpu_threads() { int thread_count = sysconf(_SC_NPROCESSORS_ONLN); thread_count = thread_count - 1; if (thread_count == 0) { thread_count = 1; } return thread_count; }