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;
}
