From f928cd4f9535f5edee6e7ae839ebd87a781b903a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:14:21 +0200 Subject: [PATCH 01/74] FIX do while: check associated(node_ptr) before accessing node_ptr%kv --- fhash.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index c05af60..4cf939d 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -392,7 +392,11 @@ subroutine next(this, key, value, status) VALUE_TYPE, intent(out) :: value integer, optional, intent(out) :: status - do while (.not. associated(this%node_ptr) .or. .not. allocated(this%node_ptr%kv)) + do + if (associated(this%node_ptr)) then + if (allocated(this%node_ptr%kv)) exit + endif + if (this%bucket_id < this%fhash_ptr%n_buckets) then this%bucket_id = this%bucket_id + 1 this%node_ptr => this%fhash_ptr%buckets(this%bucket_id) From 2b0982460452ee2b7f2fad19d71cb9e654dd7d3a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:15:58 +0200 Subject: [PATCH 02/74] deleted redundant nullify(this%next) after deallocate --- fhash.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 4cf939d..5a0e353 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -373,7 +373,6 @@ recursive subroutine node_clear(this) if (associated(this%next)) then call this%next%node_clear() deallocate(this%next) - nullify(this%next) endif end subroutine From 46dc37f8e512abf54d8eca2e747083664cf1547d Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:20:13 +0200 Subject: [PATCH 03/74] fix intent statement in node_depth: INOUT --> IN --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 5a0e353..b5d8074 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -193,7 +193,7 @@ function n_collisions(this) end function recursive function node_depth(this) result(depth) - class(node_type), intent(inout) :: this + class(node_type), intent(in) :: this integer :: depth if (.not. associated(this%next)) then From fdebc81b2eece35f9b6c9a4e46c18a80aff3464f Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:21:04 +0200 Subject: [PATCH 04/74] =?UTF-8?q?fix=20intent=20statement=20in=20n=5Fcolli?= =?UTF-8?q?sions:=20INOUT=20-->=20IN=20-=20Also=20quells=20gfortran=20=20?= =?UTF-8?q?=20"Warning:=20Impure=20function=20=E2=80=98n=5Fcollisions?= =?UTF-8?q?=E2=80=99=20at=20(1)=20might=20not=20be=20evaluated=20[-Wfuncti?= =?UTF-8?q?on-elimination]"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index b5d8074..39d0c14 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -182,7 +182,7 @@ function bucket_count(this) end function function n_collisions(this) - class(FHASH_TYPE_NAME), intent(inout) :: this + class(FHASH_TYPE_NAME), intent(in) :: this integer :: n_collisions integer :: i From 3c609b1e4de153a04aa876ed03254123956652df Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:27:51 +0200 Subject: [PATCH 05/74] fix intent statement in bucket_count: INOUT --> IN --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 39d0c14..d0561c0 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -175,7 +175,7 @@ module FHASH_MODULE_NAME contains function bucket_count(this) - class(FHASH_TYPE_NAME), intent(inout) :: this + class(FHASH_TYPE_NAME), intent(in) :: this integer :: bucket_count bucket_count = this%n_buckets From 51255db5ec2bf58946dfeff07a402e897ea4542e Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:29:59 +0200 Subject: [PATCH 06/74] added warning to "reserve" for when n_buckets is too large --- fhash.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/fhash.f90 b/fhash.f90 index d0561c0..da70f54 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -222,6 +222,8 @@ subroutine reserve(this, n_buckets) return endif enddo + + stop "Did not expect to need this many buckets." end subroutine function key_count(this) From 56d1089b338c12c9fb9277e4e960013b64ece9d0 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:30:57 +0200 Subject: [PATCH 07/74] fix intent statement in key_count: INOUT --> IN --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index da70f54..406b326 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -227,7 +227,7 @@ subroutine reserve(this, n_buckets) end subroutine function key_count(this) - class(FHASH_TYPE_NAME), intent(inout) :: this + class(FHASH_TYPE_NAME), intent(in) :: this integer :: key_count key_count = this%n_keys From 62fbb3a820f47501258ba9b4f2b333d30a6d9687 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:35:54 +0200 Subject: [PATCH 08/74] make all procedures non_overridable (clearer and also theoretically, possibly more performant) --- fhash.f90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 406b326..4dc0173 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -98,13 +98,13 @@ module FHASH_MODULE_NAME ! If kv is not allocated, allocate and set to the key, value passed in. ! If key is present and the same as the key passed in, overwrite the value. ! Otherwise, defer to the next node (allocate if not allocated) - procedure :: node_set + procedure, non_overridable :: node_set ! If kv is not allocated, fail and return 0. ! If key is present and the same as the key passed in, return the value in kv. ! If next pointer is associated, delegate to it. ! Otherwise, fail and return 0. - procedure :: node_get + procedure, non_overridable :: node_get ! If kv is not allocated, fail and return ! If key is present and node is first in bucket, set first node in bucket to @@ -113,15 +113,15 @@ module FHASH_MODULE_NAME ! previous node's next node to this node's next node, deallocate this node, ! return success ! Otherwise, fail and return 0 - procedure :: node_remove + procedure, non_overridable :: node_remove ! Deallocate kv is allocated. ! Call the clear method of the next node if the next pointer associated. ! Deallocate and nullify the next pointer. - procedure :: node_clear + procedure, non_overridable :: node_clear ! Return the length of the linked list start from the current node. - procedure :: node_depth + procedure, non_overridable :: node_depth end type type FHASH_TYPE_NAME @@ -133,28 +133,28 @@ module FHASH_MODULE_NAME contains ! Returns the number of buckets. - procedure, public :: bucket_count + procedure, non_overridable, public :: bucket_count ! Return the number of collisions. - procedure, public :: n_collisions + procedure, non_overridable, public :: n_collisions ! Reserve certain number of buckets. - procedure, public :: reserve + procedure, non_overridable, public :: reserve ! Returns number of keys. - procedure, public :: key_count + procedure, non_overridable, public :: key_count ! Set the value at a given a key. - procedure, public :: set + procedure, non_overridable, public :: set ! Get the value at the given key. - procedure, public :: get + procedure, non_overridable, public :: get ! Remove the value with the given key. - procedure, public :: remove + procedure, non_overridable, public :: remove ! Clear all the allocated memory (must be called to prevent memory leak). - procedure, public :: clear + procedure, non_overridable, public :: clear end type type FHASH_TYPE_ITERATOR_NAME @@ -166,10 +166,10 @@ module FHASH_MODULE_NAME contains ! Set the iterator to the beginning of a hash table. - procedure, public :: begin + procedure, non_overridable, public :: begin ! Get the key value of the next element and advance the iterator. - procedure, public :: next + procedure, non_overridable, public :: next end type contains From db729c252e0766d9d77b30c88f0d1c57a9053f04 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:39:09 +0200 Subject: [PATCH 09/74] fix intent statement in node_get: INOUT --> IN --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 4dc0173..b18b685 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -279,7 +279,7 @@ subroutine get(this, key, value, success) end subroutine recursive subroutine node_get(this, key, value, success) - class(node_type), intent(inout) :: this + class(node_type), intent(in) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, intent(out) :: value logical, optional, intent(out) :: success From 69159820f6fa8c6607285e4788a2486af4a27396 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:40:18 +0200 Subject: [PATCH 10/74] fix intent statement in get: INOUT --> IN --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index b18b685..e2b5cee 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -268,7 +268,7 @@ recursive subroutine node_set(this, key, value, is_new) end subroutine subroutine get(this, key, value, success) - class(FHASH_TYPE_NAME), intent(inout) :: this + class(FHASH_TYPE_NAME), intent(in) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, intent(out) :: value logical, optional, intent(out) :: success From 5f885ffd3b3690ab6303646038c52b88c4cbef27 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:44:01 +0200 Subject: [PATCH 11/74] delete trailing blanks --- fhash.f90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index e2b5cee..61af877 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -3,17 +3,17 @@ ! DO NOT COMPILE THIS TEMPLATE FILE DIRECTLY. ! Use a wrapper module and include this file instead, e.g. fhash_modules.f90. ! Remove is not implemented since not needed currently. -! +! ! #define | meaning ! --------------------------------+----------------------------------------------------- -! SHORTNAME | (optional) The name of the type this FHASH table is -! | for. If set, it overrides all settings that have +! SHORTNAME | (optional) The name of the type this FHASH table is +! | for. If set, it overrides all settings that have ! | have possibly been made for FHASH_MODULE_NAME, ! | FHASH_TYPE_NAME and FHASH_TYPE_ITERATOR_NAME. ! | ! FHASH_MODULE_NAME | The name of the module that encapsulates the FHASH ! | types and functionality -! FHASH_TYPE_NAME | The name of the actual FHASH type +! FHASH_TYPE_NAME | The name of the actual FHASH type ! FHASH_TYPE_ITERATOR_NAME | The name of the FHASH type that can iterate through ! | the whole FHASH ! | @@ -31,7 +31,7 @@ ! | values. This is the default. (see VALUE_POINTER) ! VALUE_POINTER | Flag indicating that the values in FHASH are value ! | pointers. -! VALUE_ASSIGNMENT | (internal) The assignment operator, do not set it +! VALUE_ASSIGNMENT | (internal) The assignment operator, do not set it ! | anywhere, it is configured based on VALUE_VALUE or ! | VALUE_POINTER #endif @@ -107,10 +107,10 @@ module FHASH_MODULE_NAME procedure, non_overridable :: node_get ! If kv is not allocated, fail and return - ! If key is present and node is first in bucket, set first node in bucket to + ! If key is present and node is first in bucket, set first node in bucket to ! the next node of first. Return success - ! If key is present and the node is another member of the linked list, link the - ! previous node's next node to this node's next node, deallocate this node, + ! If key is present and the node is another member of the linked list, link the + ! previous node's next node to this node's next node, deallocate this node, ! return success ! Otherwise, fail and return 0 procedure, non_overridable :: node_remove @@ -315,7 +315,7 @@ subroutine remove(this, key, success) this%buckets(bucket_id)%kv%key = this%buckets(bucket_id)%next%kv%key this%buckets(bucket_id)%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value deallocate(first%next%kv) - this%buckets(bucket_id)%next => this%buckets(bucket_id)%next%next + this%buckets(bucket_id)%next => this%buckets(bucket_id)%next%next else deallocate(this%buckets(bucket_id)%kv) endif @@ -324,7 +324,7 @@ subroutine remove(this, key, success) call node_remove(first%next, key, locSuccess, first) end if else - locSuccess = .false. + locSuccess = .false. endif if (locSuccess) this%n_keys = this%n_keys - 1 @@ -359,7 +359,7 @@ subroutine clear(this) if (.not. allocated(this%buckets)) return do i = 1, size(this%buckets) - if (associated(this%buckets(i)%next)) then + if (associated(this%buckets(i)%next)) then call this%buckets(i)%next%node_clear() deallocate(this%buckets(i)%next) endif @@ -382,7 +382,7 @@ subroutine begin(this, fhash_target) class(FHASH_TYPE_ITERATOR_NAME), intent(inout) :: this type(FHASH_TYPE_NAME), target, intent(in) :: fhash_target - this%bucket_id = 1 + this%bucket_id = 1 this%node_ptr => fhash_target%buckets(1) this%fhash_ptr => fhash_target end subroutine @@ -405,7 +405,7 @@ subroutine next(this, key, value, status) if (present(status)) status = -1 #ifdef VALUE_TYPE_INIT value VALUE_ASSIGNMENT VALUE_TYPE_INIT -#endif +#endif return endif enddo From ba3c4b51ceb07a7a02273aac0c6583fb4ad02c8a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 11:51:26 +0200 Subject: [PATCH 12/74] fix typo in comment --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 61af877..57237ec 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -115,7 +115,7 @@ module FHASH_MODULE_NAME ! Otherwise, fail and return 0 procedure, non_overridable :: node_remove - ! Deallocate kv is allocated. + ! Deallocate kv if allocated. ! Call the clear method of the next node if the next pointer associated. ! Deallocate and nullify the next pointer. procedure, non_overridable :: node_clear From 54199726c07816fe3f9470b85b473e45e3b26d68 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 13:23:16 +0200 Subject: [PATCH 13/74] use standard "ieor" intead of GNU extension "xor" --- fhash_modules.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index b82dd29..c1ccc17 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -31,7 +31,7 @@ function hash_value_ints(ints) result(hash) hash = 0 do i = 1, size(ints%ints) - hash = xor(hash, ints%ints(i) + 1640531527 + ishft(hash, 6) + ishft(hash, -2)) + hash = ieor(hash, ints%ints(i) + 1640531527 + ishft(hash, 6) + ishft(hash, -2)) enddo end function From 6b6ed506c76befdad1e2cbbfe70ea72ba21b6f78 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 17:26:21 +0200 Subject: [PATCH 14/74] in "remove": make "sizes" a parameter --- fhash.f90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 57237ec..60af0c3 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -206,24 +206,23 @@ recursive function node_depth(this) result(depth) subroutine reserve(this, n_buckets) class(FHASH_TYPE_NAME), intent(inout) :: this integer, intent(in) :: n_buckets - integer, dimension(29) :: sizes + integer :: i + integer, parameter :: sizes(*) = [5, 11, 23, 47, 97, 199, 409, 823, 1741, 3469, 6949, 14033, & + & 28411, 57557, 116731, 236897, 480881, 976369,1982627, 4026031, & + & 8175383, 16601593, 33712729, 68460391, 139022417, 282312799, & + & 573292817, 1164186217, 2147483647] if (this%key_count() > 0) stop 'Cannot reserve when fhash is not empty.' + if (n_buckets > sizes(size(sizes))) stop "Did not expect to need this many buckets." - sizes = (/5, 11, 23, 47, 97, 199, 409, 823, 1741, 3469, 6949, 14033, & - & 28411, 57557, 116731, 236897, 480881, 976369,1982627, 4026031, & - & 8175383, 16601593, 33712729, 68460391, 139022417, 282312799, & - & 573292817, 1164186217, 2147483647/) do i = 1, size(sizes) if (sizes(i) >= n_buckets) then this%n_buckets = sizes(i) allocate(this%buckets(this%n_buckets)) - return + exit endif enddo - - stop "Did not expect to need this many buckets." end subroutine function key_count(this) From 3a6500529533a8c26ec5b364ca00384cf63658af Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 16:18:15 +0200 Subject: [PATCH 15/74] added "assert" subroutine --- fhash.f90 | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 60af0c3..2dbeb2d 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -213,8 +213,8 @@ subroutine reserve(this, n_buckets) & 8175383, 16601593, 33712729, 68460391, 139022417, 282312799, & & 573292817, 1164186217, 2147483647] - if (this%key_count() > 0) stop 'Cannot reserve when fhash is not empty.' - if (n_buckets > sizes(size(sizes))) stop "Did not expect to need this many buckets." + call assert(this%key_count() == 0, 'Cannot reserve when fhash is not empty.') + call assert(sizes(size(sizes)) >= n_buckets, "Did not expect to need this many buckets.") do i = 1, size(sizes) if (sizes(i) >= n_buckets) then @@ -416,6 +416,16 @@ subroutine next(this, key, value, status) end subroutine + subroutine assert(condition, msg) + use, intrinsic :: iso_fortran_env, only: error_unit + logical, intent(in) :: condition + character(*), intent(in) :: msg + + if (.not. condition) then + write(error_unit, '(a)') msg + error stop + endif + end subroutine end module #undef KEY_TYPE From 9b4989ac0cb380e6179fec978acd0b3ac9579091 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 17:31:24 +0200 Subject: [PATCH 16/74] added missing assertion in "begin" --- fhash.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/fhash.f90 b/fhash.f90 index 2dbeb2d..35f79c3 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -382,6 +382,7 @@ subroutine begin(this, fhash_target) type(FHASH_TYPE_NAME), target, intent(in) :: fhash_target this%bucket_id = 1 + call assert(allocated(fhash_target%buckets), "cannot start iteration when fhash is empty") this%node_ptr => fhash_target%buckets(1) this%fhash_ptr => fhash_target end subroutine From 025cbf364a19a178a96de535d17f9985ee65b177 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 14:09:09 +0200 Subject: [PATCH 17/74] generalized hash_value_ints for 64-bit ints --- fhash_modules.f90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index c1ccc17..faa6acf 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -25,13 +25,21 @@ module ints_module contains function hash_value_ints(ints) result(hash) + use, intrinsic :: iso_fortran_env, only: int64, real64 type(ints_type), intent(in) :: ints - integer :: hash + integer(kind(ints%ints)) :: hash + + ! Assume either 32 or 64 bits: + integer, parameter :: bits = merge(64, 32, kind(ints%ints) == int64) + real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2 + integer, parameter :: magic_number = nint(2.0_real64**bits * (1 - 1 / phi)) ! = 1640531527 for 32 bit integer :: i hash = 0 do i = 1, size(ints%ints) - hash = ieor(hash, ints%ints(i) + 1640531527 + ishft(hash, 6) + ishft(hash, -2)) + ! This triggers an error in `gfortran` (version 9.3.0) with the `-ftrapv` option. + ! Compiler bug? + hash = ieor(hash, ints%ints(i) + magic_number + ishft(hash, 6) + ishft(hash, -2)) enddo end function From ffcc069cda8b1982270975d133c42ba81210a3b6 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 14:21:30 +0200 Subject: [PATCH 18/74] Makefile: much more extensive flags --- Makefile | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index f063f3e..d325bbf 100644 --- a/Makefile +++ b/Makefile @@ -1,12 +1,26 @@ FC := gfortran -FFLAGS := -O3 -g -fbounds-check -Wall -Wextra -cpp -Wno-unused-dummy-argument +FFLAGS = -g -fbacktrace -std=f2018 -pedantic -Wall -Wextra -cpp -Wno-unused-dummy-argument +FFLAGS += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized +FFLAGS += -Wunreachable-code -Wconversion +FFLAGS += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type +FFLAGS += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation -Wconversion +FFLAGS += -Wno-error=unused-function +FFLAGS += -Wdo-subscript -Wfunction-elimination -Wimplicit-interface -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std -Wline-truncation -Wno-tabs +FFLAGS += -Wreal-q-constant -Wsurprising +FFLAGS += -Wunused-parameter -Wfrontend-loop-interchange + +FFLAGS_DEVEL = -O0 -fcheck=all -fbounds-check -Warray-bounds -Wstrict-overflow=5 -Wunderflow -fsanitize-address-use-after-scope -ffpe-trap=invalid,zero,overflow +# FFLAGS_DEVEL += -ftrapv +FFLAGS_RELEASE = -O3 +FFLAGS += $(FFLAGS_RELEASE) .PHONY: all test clean ref all: test test: fhash_modules fhash_test.f90 - $(FC) $(FFLAGS) fhash_modules.f90 fhash_test.f90 -o fhash_test.out && ./fhash_test.out + $(FC) $(FFLAGS) fhash_modules.f90 fhash_test.f90 -o fhash_test.out \ + && ./fhash_test.out ref: benchmark.cc g++ -O3 -std=c++14 benchmark.cc -o ref.out && ./ref.out From f82b7ff7e83db3ec41cbc8dce14ab1331faa014d Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 16:22:49 +0200 Subject: [PATCH 19/74] simplified "remove" --- fhash.f90 | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 35f79c3..d9eed83 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -308,27 +308,23 @@ subroutine remove(this, key, success) bucket_id = modulo(hash_value(key), this%n_buckets) + 1 first = this%buckets(bucket_id) - if (allocated(first%kv)) then - if (first%kv%key == key) then - if (associated(first%next)) then - this%buckets(bucket_id)%kv%key = this%buckets(bucket_id)%next%kv%key - this%buckets(bucket_id)%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value - deallocate(first%next%kv) - this%buckets(bucket_id)%next => this%buckets(bucket_id)%next%next - else - deallocate(this%buckets(bucket_id)%kv) - endif - locSuccess = .true. - else - call node_remove(first%next, key, locSuccess, first) - end if - else + if (.not. allocated(first%kv)) then locSuccess = .false. + elseif (.not. first%kv%key == key) then + call node_remove(first%next, key, locSuccess, first) + elseif (associated(first%next)) then + this%buckets(bucket_id)%kv%key = this%buckets(bucket_id)%next%kv%key + this%buckets(bucket_id)%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value + deallocate(first%next%kv) + this%buckets(bucket_id)%next => this%buckets(bucket_id)%next%next + locSuccess = .true. + else + deallocate(this%buckets(bucket_id)%kv) + locSuccess = .true. endif if (locSuccess) this%n_keys = this%n_keys - 1 if (present(success)) success = locSuccess - end subroutine recursive subroutine node_remove(this, key, success, last) From 5b21919d079190306c6edfad7b348b94f7574fd5 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 16:56:00 +0200 Subject: [PATCH 20/74] in remove: "associate" avoids copying node (and is simpler) --- fhash.f90 | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index d9eed83..3a5e527 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -302,26 +302,25 @@ subroutine remove(this, key, success) logical, optional, intent(out) :: success integer :: bucket_id - type(node_type) :: first logical :: locSuccess bucket_id = modulo(hash_value(key), this%n_buckets) + 1 - first = this%buckets(bucket_id) - - if (.not. allocated(first%kv)) then - locSuccess = .false. - elseif (.not. first%kv%key == key) then - call node_remove(first%next, key, locSuccess, first) - elseif (associated(first%next)) then - this%buckets(bucket_id)%kv%key = this%buckets(bucket_id)%next%kv%key - this%buckets(bucket_id)%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value - deallocate(first%next%kv) - this%buckets(bucket_id)%next => this%buckets(bucket_id)%next%next - locSuccess = .true. - else - deallocate(this%buckets(bucket_id)%kv) - locSuccess = .true. - endif + associate(first => this%buckets(bucket_id)) + if (.not. allocated(first%kv)) then + locSuccess = .false. + elseif (.not. first%kv%key == key) then + call node_remove(first%next, key, locSuccess, first) + elseif (associated(first%next)) then + first%kv%key = first%next%kv%key + first%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value + deallocate(first%next%kv) + first%next => first%next%next + locSuccess = .true. + else + deallocate(first%kv) + locSuccess = .true. + endif + end associate if (locSuccess) this%n_keys = this%n_keys - 1 if (present(success)) success = locSuccess From a83be3e7812c7f4f1197b225d2945e3b1e544df4 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 30 Sep 2021 12:11:57 +0200 Subject: [PATCH 21/74] added finalizers to note_type - Makes 'clear' redundant; memory is deleted automatically --- fhash.f90 | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 3a5e527..b0ccee9 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -115,13 +115,16 @@ module FHASH_MODULE_NAME ! Otherwise, fail and return 0 procedure, non_overridable :: node_remove + ! Return the length of the linked list start from the current node. + procedure, non_overridable :: node_depth + ! Deallocate kv if allocated. ! Call the clear method of the next node if the next pointer associated. ! Deallocate and nullify the next pointer. - procedure, non_overridable :: node_clear - - ! Return the length of the linked list start from the current node. - procedure, non_overridable :: node_depth + ! + ! Need separate finalizers because a resursive procedure cannot be elemental. + final :: clear_scalar_node + final :: clear_rank1_nodes end type type FHASH_TYPE_NAME @@ -153,7 +156,7 @@ module FHASH_MODULE_NAME ! Remove the value with the given key. procedure, non_overridable, public :: remove - ! Clear all the allocated memory (must be called to prevent memory leak). + ! Clear all the allocated memory procedure, non_overridable, public :: clear end type @@ -347,28 +350,25 @@ recursive subroutine node_remove(this, key, success, last) end subroutine subroutine clear(this) - class(FHASH_TYPE_NAME), intent(inout) :: this - integer :: i + class(FHASH_TYPE_NAME), intent(out) :: this + end subroutine - if (.not. allocated(this%buckets)) return + subroutine clear_rank1_nodes(nodes) + type(node_type), intent(inout) :: nodes(:) - do i = 1, size(this%buckets) - if (associated(this%buckets(i)%next)) then - call this%buckets(i)%next%node_clear() - deallocate(this%buckets(i)%next) - endif + integer :: i + + do i = 1, size(nodes) + call clear_scalar_node(nodes(i)) enddo - deallocate(this%buckets) - this%n_keys = 0 - this%n_buckets = 0 end subroutine - recursive subroutine node_clear(this) - class(node_type), intent(inout) :: this + recursive subroutine clear_scalar_node(node) + type(node_type), intent(inout) :: node - if (associated(this%next)) then - call this%next%node_clear() - deallocate(this%next) + if (associated(node%next)) then + call clear_scalar_node(node%next) + deallocate(node%next) endif end subroutine From ff7d0b5f7b96c93f8e1a4c060e2358b32260b879 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 1 Oct 2021 10:30:10 +0200 Subject: [PATCH 22/74] implemented optional KEYS_EQUAL_FUNC macro --- README.md | 2 +- fhash.f90 | 20 ++++++++++++++++---- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 90545bf..9dd84a7 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Fast hash map implementation in fortran ## Description -Implemention of the GCC hashmap structure in Fortran. With the usage of macros, it can support any types of keys and values, as long as you implement (or the compiler provides) the corresponding equal operator(==), assignment operator(=) and the hash_value interface of the key type and the assignment operator of the value type. +Implemention of the GCC hashmap structure in Fortran. With the usage of macros, it can support any types of keys and values, as long as you implement (or the compiler provides) the corresponding `KEYS_EQUAL_FUNC` (defaults to `==`), assignment operator(=) and the hash_value interface of the key type and the assignment operator of the value type. ## Benchmarks diff --git a/fhash.f90 b/fhash.f90 index b0ccee9..13ceb7e 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -21,6 +21,8 @@ ! | a specific type as a key for the FHASH ! KEY_TYPE | The type of the keys. May require KEY_USE to be ! | accessible. +! KEYS_EQUAL_FUNC | (optional) function that returns whether two keys +! | are equal. Defaults to `==`. ! | ! VALUE_USE | (optional) A use statement that is required to use ! | a specific type as a value for the FHASH @@ -176,6 +178,15 @@ module FHASH_MODULE_NAME end type contains + logical function keys_equal(a, b) + KEY_TYPE, intent(in) :: a, b + +#ifdef KEYS_EQUAL_FUNC + keys_equal = KEYS_EQUAL_FUNC(a, b) +#else + keys_equal = a == b +#endif + end function function bucket_count(this) class(FHASH_TYPE_NAME), intent(in) :: this @@ -260,7 +271,7 @@ recursive subroutine node_set(this, key, value, is_new) this%kv%key = key this%kv%value VALUE_ASSIGNMENT value if (present(is_new)) is_new = .true. - else if (this%kv%key == key) then + else if (keys_equal(this%kv%key, key)) then this%kv%value VALUE_ASSIGNMENT value if (present(is_new)) is_new = .false. else @@ -289,7 +300,7 @@ recursive subroutine node_get(this, key, value, success) if (.not. allocated(this%kv)) then ! Not found. (Initial node in the bucket not set) if (present(success)) success = .false. - else if (this%kv%key == key) then + else if (keys_equal(this%kv%key, key)) then value VALUE_ASSIGNMENT this%kv%value if (present(success)) success = .true. else if (associated(this%next)) then @@ -311,7 +322,7 @@ subroutine remove(this, key, success) associate(first => this%buckets(bucket_id)) if (.not. allocated(first%kv)) then locSuccess = .false. - elseif (.not. first%kv%key == key) then + elseif (.not. keys_equal(first%kv%key, key)) then call node_remove(first%next, key, locSuccess, first) elseif (associated(first%next)) then first%kv%key = first%next%kv%key @@ -337,7 +348,7 @@ recursive subroutine node_remove(this, key, success, last) if (.not. allocated(this%kv)) then ! Not found. (Initial node in the bucket not set) success = .false. - else if (this%kv%key == key) then + else if (keys_equal(this%kv%key, key)) then last%next => this%next nullify(this%next) deallocate(this%kv) @@ -425,6 +436,7 @@ subroutine assert(condition, msg) end module #undef KEY_TYPE +#undef KEYS_EQUAL_FUNC #undef VALUE_TYPE #undef VALUE_TYPE_INIT #undef VALUE_ASSIGNMENT From 1e05187cc72c3fce74729a0d1dd508c380b6bd4f Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 1 Oct 2021 10:34:37 +0200 Subject: [PATCH 23/74] fhash_modules uses KEYS_EQUAL_FUNC --- fhash_modules.f90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index faa6acf..e3c320e 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -12,10 +12,6 @@ module ints_module module procedure hash_value_ints end interface - interface operator (==) - module procedure ints_equal - end interface - #ifdef __GFORTRAN__ interface assignment (=) module procedure ints_ptr_assign @@ -77,6 +73,7 @@ end module ints_module ! Define the macros needed by fhash and include fhash.f90 #define KEY_USE use ints_module #define KEY_TYPE type(ints_type) +#define KEYS_EQUAL_FUNC ints_equal #define VALUE_USE use, intrinsic :: iso_fortran_env #define VALUE_TYPE real(real64) #define VALUE_TYPE_INIT 0.0 From 7b44d94a77b51b76e80a55fac5a8434b9a05b37b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 15:41:07 +0200 Subject: [PATCH 24/74] implemeneted HASH_FUNC macro --- fhash.f90 | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 13ceb7e..e5e38c7 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -28,6 +28,8 @@ ! | a specific type as a value for the FHASH ! VALUE_TYPE | The type of the values. May require VALUE_USE to be ! | accessible. +! +! HASH_FUNC | (optional) hash function name. Defaults to 'hash'. ! | ! VALUE_VALUE | Flag indicating that the values in FHASH are value ! | values. This is the default. (see VALUE_POINTER) @@ -54,6 +56,10 @@ #define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) #define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) #endif + +#ifndef HASH_FUNC +#define HASH_FUNC hash_value +#endif #undef VALUE_ASSIGNMENT #ifndef VALUE_VALUE @@ -160,6 +166,8 @@ module FHASH_MODULE_NAME ! Clear all the allocated memory procedure, non_overridable, public :: clear + + procedure, non_overridable, private :: key2bucket end type type FHASH_TYPE_ITERATOR_NAME @@ -253,8 +261,7 @@ subroutine set(this, key, value) integer :: bucket_id logical :: is_new - bucket_id = modulo(hash_value(key), this%n_buckets) + 1 - + bucket_id = this%key2bucket(key) call this%buckets(bucket_id)%node_set(key, value, is_new) if (is_new) this%n_keys = this%n_keys + 1 @@ -287,7 +294,7 @@ subroutine get(this, key, value, success) logical, optional, intent(out) :: success integer :: bucket_id - bucket_id = modulo(hash_value(key), this%n_buckets) + 1 + bucket_id = this%key2bucket(key) call this%buckets(bucket_id)%node_get(key, value, success) end subroutine @@ -318,7 +325,7 @@ subroutine remove(this, key, success) integer :: bucket_id logical :: locSuccess - bucket_id = modulo(hash_value(key), this%n_buckets) + 1 + bucket_id = this%key2bucket(key) associate(first => this%buckets(bucket_id)) if (.not. allocated(first%kv)) then locSuccess = .false. @@ -363,6 +370,14 @@ recursive subroutine node_remove(this, key, success, last) subroutine clear(this) class(FHASH_TYPE_NAME), intent(out) :: this end subroutine + + integer function key2bucket(this, key) result(bucket_id) + class(FHASH_TYPE_NAME), intent(in) :: this + KEY_TYPE, intent(in) :: key + + bucket_id = modulo(HASH_FUNC(key), this%n_buckets) + 1 + end function + subroutine clear_rank1_nodes(nodes) type(node_type), intent(inout) :: nodes(:) @@ -441,6 +456,7 @@ subroutine assert(condition, msg) #undef VALUE_TYPE_INIT #undef VALUE_ASSIGNMENT #undef FHASH_TYPE_NAME +#undef HASH_FUNC #undef FHASH_TYPE_ITERATOR_NAME #undef SHORTNAME #undef CONCAT From b53abfa3e247157cb4315a14d11a73d09bdc740b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 15:47:16 +0200 Subject: [PATCH 25/74] simplified "hash_value_ints" --- fhash_modules.f90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index e3c320e..08021a8 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -25,10 +25,8 @@ function hash_value_ints(ints) result(hash) type(ints_type), intent(in) :: ints integer(kind(ints%ints)) :: hash - ! Assume either 32 or 64 bits: - integer, parameter :: bits = merge(64, 32, kind(ints%ints) == int64) real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2 - integer, parameter :: magic_number = nint(2.0_real64**bits * (1 - 1 / phi)) ! = 1640531527 for 32 bit + integer, parameter :: magic_number = nint(2.0_real64**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit integer :: i hash = 0 From da019e7e281368ee9e70a0d212652a8ff37c1bcd Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 15:55:23 +0200 Subject: [PATCH 26/74] BREAKING CHANGE: added defaults for HASH_FUNC - users will need to define HASH_FUNC excplicitly if they want a user-specied hash function --- Makefile | 2 +- fhash.f90 | 41 +++++++++++++++++++++++++++++++++++------ fhash_modules.f90 | 2 ++ 3 files changed, 38 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index d325bbf..d4716cb 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ FFLAGS += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized FFLAGS += -Wunreachable-code -Wconversion FFLAGS += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type FFLAGS += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation -Wconversion -FFLAGS += -Wno-error=unused-function +FFLAGS += -Wno-unused-function FFLAGS += -Wdo-subscript -Wfunction-elimination -Wimplicit-interface -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std -Wline-truncation -Wno-tabs FFLAGS += -Wreal-q-constant -Wsurprising FFLAGS += -Wunused-parameter -Wfrontend-loop-interchange diff --git a/fhash.f90 b/fhash.f90 index e5e38c7..ab260a0 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -29,7 +29,7 @@ ! VALUE_TYPE | The type of the values. May require VALUE_USE to be ! | accessible. ! -! HASH_FUNC | (optional) hash function name. Defaults to 'hash'. +! HASH_FUNC | (optional) hash function name. Defaults to 'hash'. ! | ! VALUE_VALUE | Flag indicating that the values in FHASH are value ! | values. This is the default. (see VALUE_POINTER) @@ -57,10 +57,6 @@ #define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) #endif -#ifndef HASH_FUNC -#define HASH_FUNC hash_value -#endif - #undef VALUE_ASSIGNMENT #ifndef VALUE_VALUE #ifndef VALUE_POINTER @@ -185,6 +181,11 @@ module FHASH_MODULE_NAME procedure, non_overridable, public :: next end type + interface default_hash + module procedure :: default_hash__int + module procedure :: default_hash__int_array + end interface + contains logical function keys_equal(a, b) KEY_TYPE, intent(in) :: a, b @@ -375,7 +376,14 @@ integer function key2bucket(this, key) result(bucket_id) class(FHASH_TYPE_NAME), intent(in) :: this KEY_TYPE, intent(in) :: key - bucket_id = modulo(HASH_FUNC(key), this%n_buckets) + 1 + integer :: hash + +#ifdef HASH_FUNC + hash = HASH_FUNC(key) +#else + hash = default_hash(key) +#endif + bucket_id = modulo(hash, this%n_buckets) + 1 end function @@ -438,6 +446,27 @@ subroutine next(this, key, value, status) end subroutine + integer function default_hash__int(key) result(hash) + integer, intent(in) :: key + + hash = key + end function + + integer function default_hash__int_array(key) result(hash) + integer, intent(in) :: key(:) + + real(kind(1.0d0)), parameter :: phi = (sqrt(5.0d0) + 1) / 2 + integer, parameter :: magic_number = nint(2.0d0**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit + integer :: i + + hash = 0 + do i = 1, size(key) + ! This triggers an error in `gfortran` (version 9.3.0) with the `-ftrapv` option. + ! Compiler bug? + hash = ieor(hash, key(i) + magic_number + ishft(hash, 6) + ishft(hash, -2)) + enddo + end function + subroutine assert(condition, msg) use, intrinsic :: iso_fortran_env, only: error_unit logical, intent(in) :: condition diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 08021a8..7892744 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -74,6 +74,7 @@ end module ints_module #define KEYS_EQUAL_FUNC ints_equal #define VALUE_USE use, intrinsic :: iso_fortran_env #define VALUE_TYPE real(real64) +#define HASH_FUNC hash_value #define VALUE_TYPE_INIT 0.0 #define SHORTNAME ints_double #include "fhash.f90" @@ -101,6 +102,7 @@ function hash_value_int(int) result(hash) #define VALUE_USE use ints_module #define VALUE_TYPE type(ints_type), pointer !#define VALUE_TYPE_INIT null() +#define HASH_FUNC hash_value #define SHORTNAME int_ints_ptr #ifndef __GFORTRAN__ #define VALUE_POINTER From e0ea05988c4ed55ea41d5aeea29fcbabeed07b74 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:05:13 +0200 Subject: [PATCH 27/74] eliminated redundant "int_module " --- fhash_modules.f90 | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 7892744..30d7754 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -79,30 +79,11 @@ end module ints_module #define SHORTNAME ints_double #include "fhash.f90" -module int_module - implicit none - - interface hash_value - module procedure hash_value_int - end interface - - contains - - function hash_value_int(int) result(hash) - integer, intent(in) :: int - integer :: hash - - hash = int - end function -end module - ! Define the macros needed by fhash and include fhash.f90 -#define KEY_USE use int_module #define KEY_TYPE integer #define VALUE_USE use ints_module #define VALUE_TYPE type(ints_type), pointer !#define VALUE_TYPE_INIT null() -#define HASH_FUNC hash_value #define SHORTNAME int_ints_ptr #ifndef __GFORTRAN__ #define VALUE_POINTER From be839caa02b3843896a6906ca0a45ab2e1cc74aa Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:06:36 +0200 Subject: [PATCH 28/74] corrected dummy declarations in ints_ptr_assign --- fhash_modules.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 30d7754..3d30037 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -60,8 +60,8 @@ function ints_equal(lhs, rhs) #ifdef __GFORTRAN__ subroutine ints_ptr_assign(lhs, rhs) - type(ints_type), pointer, intent(inout) :: lhs - type(ints_type), pointer, intent(in) :: rhs + type(ints_type), pointer, intent(out) :: lhs + type(ints_type), target, intent(in) :: rhs lhs => rhs end subroutine #endif From c3f7e311b6e3b7dbd712c072e67cd558028b15f8 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:22:09 +0200 Subject: [PATCH 29/74] implemented KEY_IS_ARRAY macro for fhash --- fhash.f90 | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index ab260a0..60aad83 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -22,7 +22,11 @@ ! KEY_TYPE | The type of the keys. May require KEY_USE to be ! | accessible. ! KEYS_EQUAL_FUNC | (optional) function that returns whether two keys -! | are equal. Defaults to `==`. +! | are equal. Defaults to `a == b` or `all(a == b)`, +! | depending on whether KEY_IS_ARRAY is defined. +! | +! KEY_IS_ARRAY | helps fhash to choose an appropriate key comparison +! | function (see KEYS_EQUAL_FUNC) ! | ! VALUE_USE | (optional) A use statement that is required to use ! | a specific type as a value for the FHASH @@ -192,8 +196,12 @@ logical function keys_equal(a, b) #ifdef KEYS_EQUAL_FUNC keys_equal = KEYS_EQUAL_FUNC(a, b) +#else +#ifdef KEY_IS_ARRAY + keys_equal = all(a == b) #else keys_equal = a == b +#endif #endif end function From 686848b024fd0d364bed2add344c554e1c108cf8 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:34:44 +0200 Subject: [PATCH 30/74] fix alignment in fhash_modules --- fhash_modules.f90 | 82 +++++++++++++++++++++++------------------------ 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 3d30037..1e58d1a 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -15,55 +15,55 @@ module ints_module #ifdef __GFORTRAN__ interface assignment (=) module procedure ints_ptr_assign - end interface + end interface #endif - - contains - - function hash_value_ints(ints) result(hash) - use, intrinsic :: iso_fortran_env, only: int64, real64 - type(ints_type), intent(in) :: ints - integer(kind(ints%ints)) :: hash - - real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2 - integer, parameter :: magic_number = nint(2.0_real64**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit - integer :: i - - hash = 0 - do i = 1, size(ints%ints) - ! This triggers an error in `gfortran` (version 9.3.0) with the `-ftrapv` option. - ! Compiler bug? - hash = ieor(hash, ints%ints(i) + magic_number + ishft(hash, 6) + ishft(hash, -2)) - enddo - end function - - function ints_equal(lhs, rhs) - type(ints_type), intent(in) :: lhs, rhs - logical :: ints_equal - integer :: i - - if (size(lhs%ints) /= size(rhs%ints)) then + +contains + + function hash_value_ints(ints) result(hash) + use, intrinsic :: iso_fortran_env, only: int64, real64 + type(ints_type), intent(in) :: ints + integer(kind(ints%ints)) :: hash + + real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2 + integer, parameter :: magic_number = nint(2.0_real64**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit + integer :: i + + hash = 0 + do i = 1, size(ints%ints) + ! This triggers an error in `gfortran` (version 9.3.0) with the `-ftrapv` option. + ! Compiler bug? + hash = ieor(hash, ints%ints(i) + magic_number + ishft(hash, 6) + ishft(hash, -2)) + enddo + end function + + function ints_equal(lhs, rhs) + type(ints_type), intent(in) :: lhs, rhs + logical :: ints_equal + integer :: i + + if (size(lhs%ints) /= size(rhs%ints)) then + ints_equal = .false. + return + endif + + do i = 1, size(lhs%ints) + if (lhs%ints(i) /= rhs%ints(i)) then ints_equal = .false. return endif + enddo - do i = 1, size(lhs%ints) - if (lhs%ints(i) /= rhs%ints(i)) then - ints_equal = .false. - return - endif - enddo - - ints_equal = .true. + ints_equal = .true. - end function + end function #ifdef __GFORTRAN__ - subroutine ints_ptr_assign(lhs, rhs) - type(ints_type), pointer, intent(out) :: lhs - type(ints_type), target, intent(in) :: rhs - lhs => rhs - end subroutine + subroutine ints_ptr_assign(lhs, rhs) + type(ints_type), pointer, intent(out) :: lhs + type(ints_type), target, intent(in) :: rhs + lhs => rhs + end subroutine #endif end module ints_module From cf9263d55209940a47ce84e73665d37ccd83a906 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:47:52 +0200 Subject: [PATCH 31/74] deleted redundant statement in fhash --- fhash.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 60aad83..8b18d7a 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -61,7 +61,6 @@ #define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) #endif -#undef VALUE_ASSIGNMENT #ifndef VALUE_VALUE #ifndef VALUE_POINTER #define VALUE_VALUE From 9fe731f4cd0844368b7170755a3abf63c760ebf1 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 16:55:19 +0200 Subject: [PATCH 32/74] deleted redundant VALUE_VALUE macro, looked like a mistake --- fhash.f90 | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 8b18d7a..bd137f4 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -35,13 +35,9 @@ ! ! HASH_FUNC | (optional) hash function name. Defaults to 'hash'. ! | -! VALUE_VALUE | Flag indicating that the values in FHASH are value -! | values. This is the default. (see VALUE_POINTER) -! VALUE_POINTER | Flag indicating that the values in FHASH are value -! | pointers. +! VALUE_POINTER | (optional) If defined, the values are pointers. ! VALUE_ASSIGNMENT | (internal) The assignment operator, do not set it -! | anywhere, it is configured based on VALUE_VALUE or -! | VALUE_POINTER +! | anywhere, it is configured based on VALUE_POINTER #endif #ifdef SHORTNAME @@ -61,12 +57,6 @@ #define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) #endif -#ifndef VALUE_VALUE -#ifndef VALUE_POINTER -#define VALUE_VALUE -#endif -#endif - #ifdef VALUE_POINTER #define VALUE_ASSIGNMENT => #else From b6fc25ef40613b9f7089a41bd18c683825e99a45 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 17:12:37 +0200 Subject: [PATCH 33/74] deleted redundant special treatment of gfortran - was confusing redefinition of default assignment operator --- fhash_modules.f90 | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 1e58d1a..9570028 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -1,5 +1,4 @@ ! Define the module for the key type. -! Override the hash_value and == operator interface. module ints_module implicit none @@ -12,12 +11,6 @@ module ints_module module procedure hash_value_ints end interface -#ifdef __GFORTRAN__ - interface assignment (=) - module procedure ints_ptr_assign - end interface -#endif - contains function hash_value_ints(ints) result(hash) @@ -57,15 +50,6 @@ function ints_equal(lhs, rhs) ints_equal = .true. end function - -#ifdef __GFORTRAN__ - subroutine ints_ptr_assign(lhs, rhs) - type(ints_type), pointer, intent(out) :: lhs - type(ints_type), target, intent(in) :: rhs - lhs => rhs - end subroutine -#endif - end module ints_module ! Define the macros needed by fhash and include fhash.f90 @@ -85,9 +69,7 @@ end module ints_module #define VALUE_TYPE type(ints_type), pointer !#define VALUE_TYPE_INIT null() #define SHORTNAME int_ints_ptr -#ifndef __GFORTRAN__ #define VALUE_POINTER -#endif #ifdef VALUE_TYPE_INIT #define CHECK_ITERATOR_VALUE #endif From cc57ceb439b0bf6da06b074db5052c3f0c840b0e Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 17:35:27 +0200 Subject: [PATCH 34/74] updated README --- README.md | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 9dd84a7..2805915 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,17 @@ Fast hash map implementation in fortran ## Description -Implemention of the GCC hashmap structure in Fortran. With the usage of macros, it can support any types of keys and values, as long as you implement (or the compiler provides) the corresponding `KEYS_EQUAL_FUNC` (defaults to `==`), assignment operator(=) and the hash_value interface of the key type and the assignment operator of the value type. +Implemention of the GCC hashmap structure in Fortran. It supports any types of keys and values, as long as you set the following macros: + +* `KEY_TYPE` and `VALUE_TYPE` with corresponding use statements `KEY_USE` and `VALUE_USE`, + +and, optionally, + +* `KEYS_EQUAL_FUNC`: the comparison operator for the keys (defaults to either `a == b` or `all(a == b)`, depending on whether `KEY_IS_ARRAY` is defined.); + +* `HASH_FUNC`, which takes a key and returns a hash integer. There are defaults for integers and integer arrays; + +* `VALUE_POINTER`: when defined the values are assumed to be pointers. ## Benchmarks From eaf080c685745bc8d5e3042da5d06f8fd1a338e4 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 18:22:10 +0200 Subject: [PATCH 35/74] do not use `nint` in parameter initialization --- Makefile | 11 ++++++----- fhash.f90 | 5 ++++- fhash_modules.f90 | 5 ++++- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index d4716cb..4acfb8c 100644 --- a/Makefile +++ b/Makefile @@ -1,13 +1,14 @@ FC := gfortran -FFLAGS = -g -fbacktrace -std=f2018 -pedantic -Wall -Wextra -cpp -Wno-unused-dummy-argument +FFLAGS = -g -fbacktrace -std=f2018 -pedantic -Wall -Wextra -cpp FFLAGS += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized -FFLAGS += -Wunreachable-code -Wconversion -FFLAGS += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type -FFLAGS += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation -Wconversion -FFLAGS += -Wno-unused-function +FFLAGS += -Wunreachable-code +FFLAGS += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation FFLAGS += -Wdo-subscript -Wfunction-elimination -Wimplicit-interface -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std -Wline-truncation -Wno-tabs FFLAGS += -Wreal-q-constant -Wsurprising FFLAGS += -Wunused-parameter -Wfrontend-loop-interchange +FFLAGS += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type +FFLAGS += -Wno-unused-function +FFLAGS += -Wno-conversion FFLAGS_DEVEL = -O0 -fcheck=all -fbounds-check -Warray-bounds -Wstrict-overflow=5 -Wunderflow -fsanitize-address-use-after-scope -ffpe-trap=invalid,zero,overflow # FFLAGS_DEVEL += -ftrapv diff --git a/fhash.f90 b/fhash.f90 index bd137f4..2954d09 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -453,7 +453,10 @@ integer function default_hash__int_array(key) result(hash) integer, intent(in) :: key(:) real(kind(1.0d0)), parameter :: phi = (sqrt(5.0d0) + 1) / 2 - integer, parameter :: magic_number = nint(2.0d0**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit + ! Do not use `nint` intrinsic, because ifort claims that "Fortran 2018 specifies that + ! "an elemental intrinsic function here be of type integer or character and + ! each argument must be an initialization expr of type integer or character": + integer, parameter :: magic_number = 0.5d0 + 2.0d0**bit_size(hash) * (1 - 1 / phi) integer :: i hash = 0 diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 9570028..8c5c64d 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -19,7 +19,10 @@ function hash_value_ints(ints) result(hash) integer(kind(ints%ints)) :: hash real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2 - integer, parameter :: magic_number = nint(2.0_real64**bit_size(hash) * (1 - 1 / phi)) ! = 1640531527 for 32 bit + ! Do not use `nint` intrinsic, because ifort claims that "Fortran 2018 specifies that + ! "an elemental intrinsic function here be of type integer or character and + ! each argument must be an initialization expr of type integer or character": + integer, parameter :: magic_number = 0.5d0 + 2.0d0**bit_size(hash) * (1 - 1 / phi) integer :: i hash = 0 From 7125a3e17fb1eed9bdef2204817a7c62dc38d7bb Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 18:32:49 +0200 Subject: [PATCH 36/74] deleted non-portable portion of fhash_test --- fhash_test.f90 | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/fhash_test.f90 b/fhash_test.f90 index eff155a..8a2528f 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -8,7 +8,6 @@ program fhash_test implicit none real :: start, finish - integer :: numKeys call test_contructor() call test_reserve() @@ -20,15 +19,8 @@ program fhash_test print *, 'ALL TESTS PASSED.' print *, 'Start benchmark:' - ! Benchmark - numKeys = 10000000 -#ifdef __GFORTRAN__ - if (__SIZEOF_POINTER__ == 8) numKeys = numKeys * 2 -#else - if (int_ptr_kind() == 8) numKeys = numKeys * 2 -#endif call cpu_time(start) - call benchmark(2, numKeys) + call benchmark(n_ints=2, n_keys=10000000) call cpu_time(finish) print '("Time finish = ", G0.3," seconds.")', finish - start From 3e57ee9f1f3d449fb00c036e518205966f42cabc Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 3 Oct 2021 19:01:20 +0200 Subject: [PATCH 37/74] added "benchmark" with fixed-size keys --- benchmark.f90 | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 benchmark.f90 diff --git a/benchmark.f90 b/benchmark.f90 new file mode 100644 index 0000000..c18975f --- /dev/null +++ b/benchmark.f90 @@ -0,0 +1,51 @@ +#define KEY_ARRAY_SIZE 2 + +#define FHASH_MODULE_NAME int_intsptr_fhash_mod +#define FHASH_TYPE_NAME int_intsptr_fhash_type +#define FHASH_TYPE_ITERATOR_NAME int_intsptr_fhash_iter_type +#define KEY_TYPE integer, dimension(KEY_ARRAY_SIZE) +#define KEY_IS_ARRAY +#define VALUE_TYPE real(real64) +#define VALUE_USE use, intrinsic :: iso_fortran_env, only: real64 +! #define VALUE_TYPE_INIT null() +! #define VALUE_POINTER +#include "fhash.f90" + +program test_benchmark + implicit none + + real :: start, finish + + print *, 'Start benchmark:' + call cpu_time(start) + call benchmark(n_ints = KEY_ARRAY_SIZE, n_keys=10000000) + call cpu_time(finish) + print '("Time finish = ", G0.3," seconds.")', finish - start + + contains + subroutine benchmark(n_ints, n_keys) + use int_intsptr_fhash_mod + use, intrinsic :: iso_fortran_env, only: real64 + + integer, intent(in) :: n_ints, n_keys + + type(int_intsptr_fhash_type) :: h + integer :: key(n_ints) + real :: start, finish + integer :: i, j + + print '("n_ints: ", I0, ", n_keys: ", I0)', n_ints, n_keys + + call cpu_time(start) + call h%reserve(n_keys * 2) + do i = 1, n_keys + do j = 1, n_ints + key(j) = i + j + enddo + call h%set(key, (i + j) * 0.5_real64) + enddo + call cpu_time(finish) + print '("Time insert = ", G0.3," seconds.")', finish - start + call h%clear() + end subroutine +end program From 5f5a5aed7d60126f883ad37ce1474eb3a4bda32f Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 4 Oct 2021 08:59:41 +0200 Subject: [PATCH 38/74] run benchmark separate from tests, with fixed-size int array --- Makefile | 6 ++++++ benchmark.cc | 39 +++++++++++++++++---------------------- benchmark.f90 | 30 +++++++++++++++--------------- 3 files changed, 38 insertions(+), 37 deletions(-) diff --git a/Makefile b/Makefile index 4acfb8c..098cae7 100644 --- a/Makefile +++ b/Makefile @@ -1,3 +1,4 @@ +CPPC = g++ FC := gfortran FFLAGS = -g -fbacktrace -std=f2018 -pedantic -Wall -Wextra -cpp FFLAGS += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized @@ -23,6 +24,11 @@ test: fhash_modules fhash_test.f90 $(FC) $(FFLAGS) fhash_modules.f90 fhash_test.f90 -o fhash_test.out \ && ./fhash_test.out +benchmark: fhash_modules.f90 benchmark.f90 + $(FC) -cpp -O3 benchmark.f90 -o fhash_benchmark.out && \ + $(CPPC) -std=c++11 -O3 benchmark.cc -o stl_benchmark.out && \ + ./stl_benchmark.out && ./fhash_benchmark.out + ref: benchmark.cc g++ -O3 -std=c++14 benchmark.cc -o ref.out && ./ref.out diff --git a/benchmark.cc b/benchmark.cc index f6a9104..5677b33 100644 --- a/benchmark.cc +++ b/benchmark.cc @@ -1,38 +1,33 @@ #include -#include -#include +#include #include #include -#include -#define N_INTS 2 -#define N_KEYS 20000000 +constexpr int N_INTS = 2; +constexpr int N_KEYS = 10000000; -void benchmark() { - typedef std::vector KeyType; - const std::clock_t start = std::clock(); - std::unordered_map> h; +int main() { + std::cout << "Start C++ STL benchmark:\n"; + + typedef std::array KeyType; + std::unordered_map, double, boost::hash> h; + + const double t0 = std::clock(); h.reserve(N_KEYS * 2); - KeyType key(N_INTS); + KeyType key; for (int i = 1; i <= N_KEYS; i++) { for (int j = 1; j <= N_INTS; j++) { key[j - 1] = i + j; } h[key] = i * 0.5; } - const std::clock_t finish = std::clock(); - printf("Time insert: %.3g s\n", - static_cast(finish - start) / CLOCKS_PER_SEC); + + const double t1 = std::clock(); h.clear(); -} -int main() { - typedef std::vector KeyType; - const std::clock_t start = std::clock(); - benchmark(); - const std::clock_t finish = std::clock(); - printf("Time finish: %.3g s\n", - static_cast(finish - start) / CLOCKS_PER_SEC); + const double t2 = std::clock(); + std::cout << "Time to assemble: " << (t1 - t0) / CLOCKS_PER_SEC << "\n"; + std::cout << "Time to clear: " << (t2 - t1) / CLOCKS_PER_SEC << "\n"; return 0; -} \ No newline at end of file +} diff --git a/benchmark.f90 b/benchmark.f90 index c18975f..b70a5c2 100644 --- a/benchmark.f90 +++ b/benchmark.f90 @@ -14,38 +14,38 @@ program test_benchmark implicit none - real :: start, finish - - print *, 'Start benchmark:' - call cpu_time(start) - call benchmark(n_ints = KEY_ARRAY_SIZE, n_keys=10000000) - call cpu_time(finish) - print '("Time finish = ", G0.3," seconds.")', finish - start + call benchmark(n_ints=KEY_ARRAY_SIZE, n_keys=10000000) - contains +contains subroutine benchmark(n_ints, n_keys) use int_intsptr_fhash_mod - use, intrinsic :: iso_fortran_env, only: real64 integer, intent(in) :: n_ints, n_keys type(int_intsptr_fhash_type) :: h integer :: key(n_ints) - real :: start, finish integer :: i, j + real :: t0, t1, t2 + + write(*,'(a)') "Start fhash benchmark:" - print '("n_ints: ", I0, ", n_keys: ", I0)', n_ints, n_keys + write(*,'("n_ints: ", I0, ", n_keys: ", I0)') n_ints, n_keys - call cpu_time(start) + call cpu_time(t0) call h%reserve(n_keys * 2) do i = 1, n_keys do j = 1, n_ints key(j) = i + j enddo - call h%set(key, (i + j) * 0.5_real64) + call h%set(key, i * 0.5d0) enddo - call cpu_time(finish) - print '("Time insert = ", G0.3," seconds.")', finish - start + + call cpu_time(t1) + call h%clear() + call cpu_time(t2) + + write(*,'(a,g0.3)') "Time to assemble: ", t1 - t0 + write(*,'(a,g0.3)') "Time to clear: ", t2 - t1 end subroutine end program From 62a9e200bb7569e24275fabceb9f90544f7b795f Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 4 Oct 2021 10:15:34 +0200 Subject: [PATCH 39/74] no finalization for old gortran versions --- fhash.f90 | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 2954d09..aec5315 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -62,6 +62,17 @@ #else #define VALUE_ASSIGNMENT = #endif + +! Not all compilers implement finalization: +#if defined __GFORTRAN__ && __GNUC__ <= 5 +#else +# define _FINAL_IS_IMPLEMENTED +#endif +#ifdef _FINAL_IS_IMPLEMENTED +# define _FINAL_TYPEORCLASS type +#else +# define _FINAL_TYPEORCLASS class +#endif module FHASH_MODULE_NAME #undef FHASH_MODULE_NAME @@ -120,9 +131,16 @@ module FHASH_MODULE_NAME ! Deallocate and nullify the next pointer. ! ! Need separate finalizers because a resursive procedure cannot be elemental. +#ifdef _FINAL_IS_IMPLEMENTED final :: clear_scalar_node final :: clear_rank1_nodes - end type +#else + ! Old `gfortran` versions think the passed dummy must be a scalar: + generic, public :: clear => clear_scalar_node + procedure, non_overridable, private :: clear_scalar_node + ! procedure, non_overridable, private :: clear_rank1_nodes +#endif + end type type FHASH_TYPE_NAME private @@ -385,7 +403,7 @@ integer function key2bucket(this, key) result(bucket_id) subroutine clear_rank1_nodes(nodes) - type(node_type), intent(inout) :: nodes(:) + _FINAL_TYPEORCLASS(node_type), intent(inout) :: nodes(:) integer :: i @@ -395,7 +413,7 @@ subroutine clear_rank1_nodes(nodes) end subroutine recursive subroutine clear_scalar_node(node) - type(node_type), intent(inout) :: node + _FINAL_TYPEORCLASS(node_type), intent(inout) :: node if (associated(node%next)) then call clear_scalar_node(node%next) @@ -479,6 +497,8 @@ subroutine assert(condition, msg) end subroutine end module +#undef _FINAL_IS_IMPLEMENTED +#undef _FINAL_TYPEORCLASS #undef KEY_TYPE #undef KEYS_EQUAL_FUNC #undef VALUE_TYPE @@ -489,4 +509,4 @@ subroutine assert(condition, msg) #undef FHASH_TYPE_ITERATOR_NAME #undef SHORTNAME #undef CONCAT -#undef PASTE +#undef PASTE \ No newline at end of file From 8ebbeee63040d76cf2b8551235da0d38fc06b72c Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 4 Oct 2021 10:24:55 +0200 Subject: [PATCH 40/74] Makefile: ajusted to old gfortran version --- Makefile | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/Makefile b/Makefile index 098cae7..1bf5ab8 100644 --- a/Makefile +++ b/Makefile @@ -1,20 +1,25 @@ CPPC = g++ FC := gfortran -FFLAGS = -g -fbacktrace -std=f2018 -pedantic -Wall -Wextra -cpp -FFLAGS += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized -FFLAGS += -Wunreachable-code -FFLAGS += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation -FFLAGS += -Wdo-subscript -Wfunction-elimination -Wimplicit-interface -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std -Wline-truncation -Wno-tabs -FFLAGS += -Wreal-q-constant -Wsurprising -FFLAGS += -Wunused-parameter -Wfrontend-loop-interchange -FFLAGS += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type -FFLAGS += -Wno-unused-function -FFLAGS += -Wno-conversion - -FFLAGS_DEVEL = -O0 -fcheck=all -fbounds-check -Warray-bounds -Wstrict-overflow=5 -Wunderflow -fsanitize-address-use-after-scope -ffpe-trap=invalid,zero,overflow +FFLAGS_BASIC = -g -fbacktrace -std=f2008 -pedantic -Wall -Wextra -cpp +FFLAGS_BASIC += -Werror -Werror=shadow -Werror=intrinsic-shadow -Wuninitialized +FFLAGS_BASIC += -Wunreachable-code -Wconversion +FFLAGS_BASIC += -Waliasing -Wampersand -Wc-binding-type -Wcharacter-truncation +FFLAGS_BASIC += -Wfunction-elimination -Wimplicit-interface -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std -Wline-truncation -Wno-tabs +FFLAGS_BASIC += -Wreal-q-constant -Wsurprising +FFLAGS_BASIC += -Wunused-parameter +FFLAGS_BASIC += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type +FFLAGS_BASIC += -Wno-unused-function +FFLAGS_BASIC += -Wno-conversion + +FFLAGS_DEVEL = -O0 -fcheck=all -fbounds-check -Warray-bounds -Wstrict-overflow=5 -Wunderflow -ffpe-trap=invalid,zero,overflow # FFLAGS_DEVEL += -ftrapv FFLAGS_RELEASE = -O3 -FFLAGS += $(FFLAGS_RELEASE) + +# not yet in gfortran 4.8.5: +# FFLAGS_BASIC += -Wdo-subscript -std=f2018 -Wfrontend-loop-interchange +# FFLAGS_DEVEL += -fsanitize-address-use-after-scope + +FFLAGS = $(FFLAGS_BASIC) $(FFLAGS_DEVEL) .PHONY: all test clean ref @@ -25,9 +30,9 @@ test: fhash_modules fhash_test.f90 && ./fhash_test.out benchmark: fhash_modules.f90 benchmark.f90 - $(FC) -cpp -O3 benchmark.f90 -o fhash_benchmark.out && \ + $(FC) $(FFLAGS_BASIC) $(FFLAGS_RELEASE) benchmark.f90 -o fhash_benchmark.out && \ $(CPPC) -std=c++11 -O3 benchmark.cc -o stl_benchmark.out && \ - ./stl_benchmark.out && ./fhash_benchmark.out + ./fhash_benchmark.out && ./stl_benchmark.out ref: benchmark.cc g++ -O3 -std=c++14 benchmark.cc -o ref.out && ./ref.out From 0f8bd0d3637e43563579f9180697868ea9ed245c Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 4 Oct 2021 10:41:26 +0200 Subject: [PATCH 41/74] deleted benshmark from fhash_test --- fhash_test.f90 | 33 --------------------------------- 1 file changed, 33 deletions(-) diff --git a/fhash_test.f90 b/fhash_test.f90 index 8a2528f..8ff1ce2 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -7,8 +7,6 @@ program fhash_test implicit none - real :: start, finish - call test_contructor() call test_reserve() call test_insert_and_get_ints_double() @@ -17,13 +15,6 @@ program fhash_test call test_iterate() print *, 'ALL TESTS PASSED.' - print *, 'Start benchmark:' - - call cpu_time(start) - call benchmark(n_ints=2, n_keys=10000000) - call cpu_time(finish) - print '("Time finish = ", G0.3," seconds.")', finish - start - contains subroutine test_contructor() @@ -209,28 +200,4 @@ subroutine test_iterate() call h%clear() end subroutine - - subroutine benchmark(n_ints, n_keys) - integer, intent(in) :: n_ints, n_keys - type(fhash_type__ints_double) :: h - type(ints_type) :: key - real :: start, finish - integer :: i, j - - print '("n_ints: ", I0, ", n_keys: ", I0)', n_ints, n_keys - - call cpu_time(start) - call h%reserve(n_keys * 2) - allocate(key%ints(n_ints)) - do i = 1, n_keys - do j = 1, n_ints - key%ints(j) = i + j - enddo - call h%set(key, (i + j) * 0.5_real64) - enddo - call cpu_time(finish) - print '("Time insert = ", G0.3," seconds.")', finish - start - call h%clear() - end subroutine - end program From d91b00f0671ed33f37553ba46ec9e7136fdf1eff Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sat, 9 Oct 2021 08:08:26 +0200 Subject: [PATCH 42/74] make 'clear' and 'reserve' elemental --- fhash.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index aec5315..9d844fa 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -241,7 +241,7 @@ recursive function node_depth(this) result(depth) endif end function - subroutine reserve(this, n_buckets) + impure elemental subroutine reserve(this, n_buckets) class(FHASH_TYPE_NAME), intent(inout) :: this integer, intent(in) :: n_buckets @@ -383,7 +383,7 @@ recursive subroutine node_remove(this, key, success, last) endif end subroutine - subroutine clear(this) + impure elemental subroutine clear(this) class(FHASH_TYPE_NAME), intent(out) :: this end subroutine From 38f650cb49cc237b50899ddf0d7e43768364acde Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sat, 9 Oct 2021 08:15:24 +0200 Subject: [PATCH 43/74] no need to #define KEY_IS_ARRAY --- README.md | 2 +- benchmark.f90 | 1 - fhash.f90 | 19 +++++++++++-------- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 2805915..f3aa630 100644 --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ Implemention of the GCC hashmap structure in Fortran. It supports any types of k and, optionally, -* `KEYS_EQUAL_FUNC`: the comparison operator for the keys (defaults to either `a == b` or `all(a == b)`, depending on whether `KEY_IS_ARRAY` is defined.); +* `KEYS_EQUAL_FUNC`: the comparison operator for the keys (defaults to either `a == b` or `all(a == b)`, depending on whether the key is a scalar; * `HASH_FUNC`, which takes a key and returns a hash integer. There are defaults for integers and integer arrays; diff --git a/benchmark.f90 b/benchmark.f90 index b70a5c2..e14b909 100644 --- a/benchmark.f90 +++ b/benchmark.f90 @@ -4,7 +4,6 @@ #define FHASH_TYPE_NAME int_intsptr_fhash_type #define FHASH_TYPE_ITERATOR_NAME int_intsptr_fhash_iter_type #define KEY_TYPE integer, dimension(KEY_ARRAY_SIZE) -#define KEY_IS_ARRAY #define VALUE_TYPE real(real64) #define VALUE_USE use, intrinsic :: iso_fortran_env, only: real64 ! #define VALUE_TYPE_INIT null() diff --git a/fhash.f90 b/fhash.f90 index 9d844fa..0532c46 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -23,10 +23,7 @@ ! | accessible. ! KEYS_EQUAL_FUNC | (optional) function that returns whether two keys ! | are equal. Defaults to `a == b` or `all(a == b)`, -! | depending on whether KEY_IS_ARRAY is defined. -! | -! KEY_IS_ARRAY | helps fhash to choose an appropriate key comparison -! | function (see KEYS_EQUAL_FUNC) +! | depending on whether the key is a scalar. ! | ! VALUE_USE | (optional) A use statement that is required to use ! | a specific type as a value for the FHASH @@ -197,6 +194,10 @@ module FHASH_MODULE_NAME module procedure :: default_hash__int_array end interface + interface all + module procedure :: scalar_all + end interface + contains logical function keys_equal(a, b) KEY_TYPE, intent(in) :: a, b @@ -204,11 +205,7 @@ logical function keys_equal(a, b) #ifdef KEYS_EQUAL_FUNC keys_equal = KEYS_EQUAL_FUNC(a, b) #else -#ifdef KEY_IS_ARRAY keys_equal = all(a == b) -#else - keys_equal = a == b -#endif #endif end function @@ -485,6 +482,12 @@ integer function default_hash__int_array(key) result(hash) enddo end function + logical function scalar_all(scal) + logical, intent(in) :: scal + + scalar_all = scal + end function + subroutine assert(condition, msg) use, intrinsic :: iso_fortran_env, only: error_unit logical, intent(in) :: condition From dca46f3afd9e42a01009301bdaa88ceacd301be9 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Tue, 12 Oct 2021 16:16:25 +0200 Subject: [PATCH 44/74] addd assertion: at least one bucket --- fhash.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/fhash.f90 b/fhash.f90 index 0532c46..a7ed1f7 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -249,6 +249,7 @@ impure elemental subroutine reserve(this, n_buckets) & 573292817, 1164186217, 2147483647] call assert(this%key_count() == 0, 'Cannot reserve when fhash is not empty.') + call assert(n_buckets >= 1, "I need at least one bucket.") call assert(sizes(size(sizes)) >= n_buckets, "Did not expect to need this many buckets.") do i = 1, size(sizes) From 3559147cc95c40fe031a19855dce7a6db42174b4 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 22 Oct 2021 12:03:31 +0200 Subject: [PATCH 45/74] added assignment oper --- fhash.f90 | 35 +++++++++++++++++++++ fhash_test.f90 | 85 ++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 118 insertions(+), 2 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index a7ed1f7..ea88af2 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -171,6 +171,9 @@ module FHASH_MODULE_NAME ! Clear all the allocated memory procedure, non_overridable, public :: clear + generic, public :: assignment(=) => deepcopy_fhash + procedure, non_overridable, private :: deepcopy_fhash + procedure, non_overridable, private :: key2bucket end type @@ -381,6 +384,38 @@ recursive subroutine node_remove(this, key, success, last) endif end subroutine + impure elemental subroutine deepcopy_fhash(lhs, rhs) + class(FHASH_TYPE_NAME), intent(out) :: lhs + type(FHASH_TYPE_NAME), intent(in) :: rhs + + integer :: i + + if (.not. allocated(rhs%buckets)) return + + lhs%n_buckets = rhs%n_buckets + lhs%n_keys = rhs%n_keys + allocate(lhs%buckets(size(rhs%buckets))) + do i = 1, size(lhs%buckets) + call deepcopy_node(rhs%buckets(i), lhs%buckets(i)) + enddo + end subroutine + + recursive subroutine deepcopy_node(this, copy) + class(node_type), intent(in) :: this + type(node_type), intent(out) :: copy + + if (.not. allocated(this%kv)) then + call assert(.not. associated(this%next), 'internal error: node has a "next" pointer, but it''s kv pair has not been set') + else + allocate(copy%kv, source=this%kv) + endif + + if (associated(this%next)) then + allocate(copy%next) + call deepcopy_node(this%next, copy%next) + endif + end subroutine + impure elemental subroutine clear(this) class(FHASH_TYPE_NAME), intent(out) :: this end subroutine diff --git a/fhash_test.f90 b/fhash_test.f90 index 8ff1ce2..0412b51 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -1,10 +1,91 @@ +module tests_mod + use ints_module + use fhash_module__ints_double + use, intrinsic :: iso_fortran_env + implicit none + +contains + subroutine test_assignment() + type(fhash_type__ints_double) :: a, b, c + type(ints_type) :: keys(100) + real(real64) :: values(size(keys)) + + integer :: i + + do i = 1, size(keys) + allocate(keys(i)%ints(3)) + keys(i)%ints = i + values(i) = i + enddo + + call a%reserve(10) + do i = 1, size(keys) + call a%set(keys(i), values(i)) + enddo + call check_kv(a) + + c = a + call check_kv(a) + call check_kv(c) + + call b%reserve(1) + b = a + call check_kv(a) + call check_kv(b) + call a%clear() + call check_kv(b) + + a = b + call check_kv(a) + call check_kv(b) + call a%clear() + call check_kv(b) + contains + subroutine check_kv(fhash) + type(fhash_type__ints_double), intent(in) :: fhash + + type(fhash_type_iterator__ints_double) :: iter + type(ints_type) :: key + real(real64) :: val + integer :: i + integer :: status + logical :: have_seen(size(keys)) + + have_seen = .false. + call iter%begin(fhash) + do + call iter%next(key, val, status) + if (status /= 0) exit + + i = nint(val) + call assert(abs(val - i) <= 10*epsilon(val), "check_kv: bad value") + call assert(key%ints == i, "check_kv: bad key") + call assert(.not. have_seen(i), "check_kv: found the same key twice") + have_seen(i) = .true. + enddo + call assert(all(have_seen), "check_kv: did not get all keys from the iterator") + end subroutine + end subroutine + + impure elemental subroutine assert(condition, msg) + use, intrinsic :: iso_fortran_env, only: error_unit + logical, intent(in) :: condition + character(*), intent(in) :: msg + + if (.not. condition) then + write(error_unit, '(a)') "FAILED A TEST: " // msg + error stop + endif + end subroutine +end module + program fhash_test use, intrinsic :: iso_fortran_env use fhash_module__ints_double use fhash_module__int_ints_ptr use ints_module - + use tests_mod implicit none call test_contructor() @@ -13,6 +94,7 @@ program fhash_test call test_insert_and_get_int_ints_ptr() call test_insert_get_and_remove_int_ints_ptr() call test_iterate() + call test_assignment() print *, 'ALL TESTS PASSED.' contains @@ -150,7 +232,6 @@ subroutine test_insert_get_and_remove_int_ints_ptr() call h%clear() deallocate(pValues) - end subroutine subroutine test_iterate() From a6673b1ee98824bf0130b641cd44400a9d21427b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 25 Oct 2021 16:17:17 +0200 Subject: [PATCH 46/74] added "deep_storage_size" function --- fhash.f90 | 26 ++++++++++++++++++++++++++ fhash_test.f90 | 26 ++++++++++++++++++++++++++ 2 files changed, 52 insertions(+) diff --git a/fhash.f90 b/fhash.f90 index ea88af2..6de3d90 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -168,6 +168,10 @@ module FHASH_MODULE_NAME ! Remove the value with the given key. procedure, non_overridable, public :: remove + ! Return the accumalated storage size of an fhash, including the underlying pointers. + ! Takes the bit size of a key-value pair as an argument. + procedure, non_overridable, public :: deep_storage_size => fhash_deep_storage_size + ! Clear all the allocated memory procedure, non_overridable, public :: clear @@ -416,6 +420,28 @@ recursive subroutine deepcopy_node(this, copy) endif end subroutine + impure elemental integer function fhash_deep_storage_size(this, keyval_ss) result(s) + class(FHASH_TYPE_NAME), intent(in) :: this + integer, intent(in) :: keyval_ss + + integer :: i + + s = storage_size(this) + if (allocated(this%buckets)) then + do i = 1, size(this%buckets) + s = s + node_deep_storage_size(this%buckets(i), keyval_ss) + enddo + endif + end function + + recursive integer function node_deep_storage_size(node, keyval_ss) result(s) + type(node_type), intent(in) :: node + integer, intent(in) :: keyval_ss + + s = storage_size(node) + keyval_ss + if (associated(node%next)) s = s + node_deep_storage_size(node%next, keyval_ss) + end function + impure elemental subroutine clear(this) class(FHASH_TYPE_NAME), intent(out) :: this end subroutine diff --git a/fhash_test.f90 b/fhash_test.f90 index 0412b51..ad2e0d3 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -5,6 +5,31 @@ module tests_mod implicit none contains + subroutine test_deep_storage_size() + type(fhash_type__ints_double) :: h + type(ints_type) :: key + + integer :: i + integer :: s + + s = h%deep_storage_size(0123) + + call h%reserve(10) + allocate(key%ints(2)) + + do i = 1, 3 + key%ints = i + call h%set(key, real(i, kind=real64)) + enddo + s = h%deep_storage_size(0123) + + do i = 1, 20 + key%ints = i + call h%set(key, real(i, kind=real64)) + enddo + s = h%deep_storage_size(0123) + end subroutine + subroutine test_assignment() type(fhash_type__ints_double) :: a, b, c type(ints_type) :: keys(100) @@ -94,6 +119,7 @@ program fhash_test call test_insert_and_get_int_ints_ptr() call test_insert_get_and_remove_int_ints_ptr() call test_iterate() + call test_deep_storage_size() call test_assignment() print *, 'ALL TESTS PASSED.' From 0d563b9b14c4cf7b3c6f24982ac8dddd7eac905b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 27 Oct 2021 08:04:46 +0200 Subject: [PATCH 47/74] added "get_ptr" method --- fhash.f90 | 102 +++++++++++++++++++++++++++++++++++++++---------- fhash_test.f90 | 15 +++++++- 2 files changed, 95 insertions(+), 22 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 6de3d90..d0df585 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -105,12 +105,6 @@ module FHASH_MODULE_NAME ! Otherwise, defer to the next node (allocate if not allocated) procedure, non_overridable :: node_set - ! If kv is not allocated, fail and return 0. - ! If key is present and the same as the key passed in, return the value in kv. - ! If next pointer is associated, delegate to it. - ! Otherwise, fail and return 0. - procedure, non_overridable :: node_get - ! If kv is not allocated, fail and return ! If key is present and node is first in bucket, set first node in bucket to ! the next node of first. Return success @@ -144,7 +138,7 @@ module FHASH_MODULE_NAME integer :: n_buckets = 0 integer :: n_keys = 0 - type(node_type), allocatable :: buckets(:) + type(node_type), contiguous, pointer :: buckets(:) => null() contains ! Returns the number of buckets. @@ -165,6 +159,10 @@ module FHASH_MODULE_NAME ! Get the value at the given key. procedure, non_overridable, public :: get +#ifndef VALUE_POINTER + procedure, non_overridable, public :: get_ptr +#endif + ! Remove the value with the given key. procedure, non_overridable, public :: remove @@ -174,7 +172,9 @@ module FHASH_MODULE_NAME ! Clear all the allocated memory procedure, non_overridable, public :: clear - +#ifdef _FINAL_IS_IMPLEMENTED + final :: clear_final +#endif generic, public :: assignment(=) => deepcopy_fhash procedure, non_overridable, private :: deepcopy_fhash @@ -220,7 +220,11 @@ function bucket_count(this) class(FHASH_TYPE_NAME), intent(in) :: this integer :: bucket_count - bucket_count = this%n_buckets + if (.not. associated(this%buckets)) then + bucket_count = 0 + else + bucket_count = size(this%buckets) + endif end function function n_collisions(this) @@ -228,6 +232,8 @@ function n_collisions(this) integer :: n_collisions integer :: i + call assert(associated(this%buckets), "n_collisions: fhash has not been initialized") + n_collisions = 0 do i = 1, this%n_buckets n_collisions = n_collisions + node_depth(this%buckets(i)) - 1 @@ -282,6 +288,8 @@ subroutine set(this, key, value) integer :: bucket_id logical :: is_new + call assert(associated(this%buckets), "set: fhash has not been initialized") + bucket_id = this%key2bucket(key) call this%buckets(bucket_id)%node_set(key, value, is_new) @@ -313,14 +321,21 @@ subroutine get(this, key, value, success) KEY_TYPE, intent(in) :: key VALUE_TYPE, intent(out) :: value logical, optional, intent(out) :: success + integer :: bucket_id + call assert(associated(this%buckets), "get: fhash has not been initialized") + bucket_id = this%key2bucket(key) - call this%buckets(bucket_id)%node_get(key, value, success) + call node_get(this%buckets(bucket_id), key, value, success) end subroutine recursive subroutine node_get(this, key, value, success) - class(node_type), intent(in) :: this + ! If kv is not allocated, fail and return 0. + ! If key is present and the same as the key passed in, return the value in kv. + ! If next pointer is associated, delegate to it. + ! Otherwise, fail and return 0. + type(node_type), intent(in) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, intent(out) :: value logical, optional, intent(out) :: success @@ -332,12 +347,43 @@ recursive subroutine node_get(this, key, value, success) value VALUE_ASSIGNMENT this%kv%value if (present(success)) success = .true. else if (associated(this%next)) then - call this%next%node_get(key, value, success) - else - if (present(success)) success = .false. + call node_get(this%next, key, value, success) + elseif (present(success)) then + success = .false. endif end subroutine +#ifndef VALUE_POINTER + function get_ptr(this, key) result(value) + class(FHASH_TYPE_NAME), intent(in) :: this + KEY_TYPE, intent(in) :: key + VALUE_TYPE, pointer :: value + + integer :: bucket_id + + call assert(associated(this%buckets), "get: fhash has not been initialized") + + bucket_id = this%key2bucket(key) + value => node_get_ptr(this%buckets(bucket_id), key) + end function + + recursive function node_get_ptr(this, key) result(value) + type(node_type), target, intent(in) :: this + KEY_TYPE, intent(in) :: key + VALUE_TYPE, pointer :: value + + if (.not. allocated(this%kv)) then + value => null() + else if (keys_equal(this%kv%key, key)) then + value => this%kv%value + else if (.not. associated(this%next)) then + value => null() + else + value => node_get_ptr(this%next, key) + endif + end function +#endif + subroutine remove(this, key, success) class(FHASH_TYPE_NAME), intent(inout) :: this KEY_TYPE, intent(in) :: key @@ -346,6 +392,8 @@ subroutine remove(this, key, success) integer :: bucket_id logical :: locSuccess + call assert(associated(this%buckets), "remove: fhash has not been initialized") + bucket_id = this%key2bucket(key) associate(first => this%buckets(bucket_id)) if (.not. allocated(first%kv)) then @@ -394,7 +442,7 @@ impure elemental subroutine deepcopy_fhash(lhs, rhs) integer :: i - if (.not. allocated(rhs%buckets)) return + if (.not. associated(rhs%buckets)) return lhs%n_buckets = rhs%n_buckets lhs%n_keys = rhs%n_keys @@ -427,7 +475,7 @@ impure elemental integer function fhash_deep_storage_size(this, keyval_ss) resul integer :: i s = storage_size(this) - if (allocated(this%buckets)) then + if (associated(this%buckets)) then do i = 1, size(this%buckets) s = s + node_deep_storage_size(this%buckets(i), keyval_ss) enddo @@ -443,9 +491,21 @@ recursive integer function node_deep_storage_size(node, keyval_ss) result(s) end function impure elemental subroutine clear(this) - class(FHASH_TYPE_NAME), intent(out) :: this + class(FHASH_TYPE_NAME), intent(inout) :: this + + this%n_buckets = 0 + this%n_keys = 0 + if (associated(this%buckets)) deallocate(this%buckets) end subroutine - + +#ifdef _FINAL_IS_IMPLEMENTED + impure elemental subroutine clear_final(this) + type(FHASH_TYPE_NAME), intent(inout) :: this + + call this%clear() + end subroutine +#endif + integer function key2bucket(this, key) result(bucket_id) class(FHASH_TYPE_NAME), intent(in) :: this KEY_TYPE, intent(in) :: key @@ -484,8 +544,9 @@ subroutine begin(this, fhash_target) class(FHASH_TYPE_ITERATOR_NAME), intent(inout) :: this type(FHASH_TYPE_NAME), target, intent(in) :: fhash_target + call assert(associated(fhash_target%buckets), "cannot start iteration when fhash is empty") + this%bucket_id = 1 - call assert(allocated(fhash_target%buckets), "cannot start iteration when fhash is empty") this%node_ptr => fhash_target%buckets(1) this%fhash_ptr => fhash_target end subroutine @@ -496,6 +557,8 @@ subroutine next(this, key, value, status) VALUE_TYPE, intent(out) :: value integer, optional, intent(out) :: status + call assert(associated(this%fhash_ptr), "next: iterator has not been initialized") + do if (associated(this%node_ptr)) then if (allocated(this%node_ptr%kv)) exit @@ -517,7 +580,6 @@ subroutine next(this, key, value, status) value VALUE_ASSIGNMENT this%node_ptr%kv%value if (present(status)) status = 0 this%node_ptr => this%node_ptr%next - end subroutine integer function default_hash__int(key) result(hash) diff --git a/fhash_test.f90 b/fhash_test.f90 index ad2e0d3..cb74fa5 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -131,15 +131,17 @@ subroutine test_contructor() end subroutine subroutine test_reserve() - type(fhash_type__ints_double) h + type(fhash_type__ints_double) :: h + call h%reserve(3) - if (h%bucket_count() /= 5) stop 'expect to reserve 5 buckets' + call assert(h%bucket_count() == 5, 'expected to reserve 5 buckets') end subroutine subroutine test_insert_and_get_ints_double() type(fhash_type__ints_double) :: h type(ints_type) :: key real(real64) :: value + real(real64), pointer :: val_ptr integer :: i logical :: success call h%reserve(5) @@ -148,11 +150,20 @@ subroutine test_insert_and_get_ints_double() key%ints = 0 do i = 1, 10 key%ints(i) = i + call h%get(key, value, success) if (success) stop 'expect not found' + + val_ptr => h%get_ptr(key) + call assert(.not. associated(val_ptr), "expected a null pointer") + call h%set(key, i * 0.5_real64) call h%get(key, value) if (abs(value - i * 0.5_real64) > epsilon(value)) stop 'expect to get 0.5 i' + + val_ptr => h%get_ptr(key) + call assert(associated(val_ptr), "expected a, associated pointer") + call assert(abs(val_ptr - i * 0.5_real64) <= epsilon(val_ptr), 'expect to get pointer value of 0.5 i') enddo if (h%key_count() /= 10) stop 'expect key count to be 10' if (h%n_collisions() >= 10 .or. h%n_collisions() < 5) stop 'expect n_collisions in [5, 10)' From e0a48786eddd8e80b8a9b42780f50b05c03373f1 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 27 Oct 2021 08:19:34 +0200 Subject: [PATCH 48/74] remove redundant n_buckets attribute; triggers gfortran (compiler?) error --- fhash.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index d0df585..6d2f34b 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -136,7 +136,6 @@ module FHASH_MODULE_NAME type FHASH_TYPE_NAME private - integer :: n_buckets = 0 integer :: n_keys = 0 type(node_type), contiguous, pointer :: buckets(:) => null() @@ -235,7 +234,7 @@ function n_collisions(this) call assert(associated(this%buckets), "n_collisions: fhash has not been initialized") n_collisions = 0 - do i = 1, this%n_buckets + do i = 1, size(this%buckets) n_collisions = n_collisions + node_depth(this%buckets(i)) - 1 enddo end function @@ -267,8 +266,7 @@ impure elemental subroutine reserve(this, n_buckets) do i = 1, size(sizes) if (sizes(i) >= n_buckets) then - this%n_buckets = sizes(i) - allocate(this%buckets(this%n_buckets)) + allocate(this%buckets(sizes(i))) exit endif enddo @@ -360,11 +358,15 @@ function get_ptr(this, key) result(value) VALUE_TYPE, pointer :: value integer :: bucket_id + type(node_type), pointer :: bucket call assert(associated(this%buckets), "get: fhash has not been initialized") - + bucket_id = this%key2bucket(key) - value => node_get_ptr(this%buckets(bucket_id), key) + call assert(1 <= bucket_id .and. bucket_id <= size(this%buckets), "get: fhash has not been initialized") + bucket => this%buckets(bucket_id) + + value => node_get_ptr(bucket, key) end function recursive function node_get_ptr(this, key) result(value) @@ -444,7 +446,6 @@ impure elemental subroutine deepcopy_fhash(lhs, rhs) if (.not. associated(rhs%buckets)) return - lhs%n_buckets = rhs%n_buckets lhs%n_keys = rhs%n_keys allocate(lhs%buckets(size(rhs%buckets))) do i = 1, size(lhs%buckets) @@ -493,7 +494,6 @@ recursive integer function node_deep_storage_size(node, keyval_ss) result(s) impure elemental subroutine clear(this) class(FHASH_TYPE_NAME), intent(inout) :: this - this%n_buckets = 0 this%n_keys = 0 if (associated(this%buckets)) deallocate(this%buckets) end subroutine @@ -517,7 +517,7 @@ integer function key2bucket(this, key) result(bucket_id) #else hash = default_hash(key) #endif - bucket_id = modulo(hash, this%n_buckets) + 1 + bucket_id = modulo(hash, size(this%buckets)) + 1 end function @@ -564,7 +564,7 @@ subroutine next(this, key, value, status) if (allocated(this%node_ptr%kv)) exit endif - if (this%bucket_id < this%fhash_ptr%n_buckets) then + if (this%bucket_id < size(this%fhash_ptr%buckets)) then this%bucket_id = this%bucket_id + 1 this%node_ptr => this%fhash_ptr%buckets(this%bucket_id) else From 7a7f74527c37c721fd2684d1c3d9e2dd9dba6bd3 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 10:24:16 +0100 Subject: [PATCH 49/74] make kv_type public --- fhash.f90 | 45 +++++++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 6d2f34b..9091dfc 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -9,7 +9,8 @@ ! SHORTNAME | (optional) The name of the type this FHASH table is ! | for. If set, it overrides all settings that have ! | have possibly been made for FHASH_MODULE_NAME, -! | FHASH_TYPE_NAME and FHASH_TYPE_ITERATOR_NAME. +! | FHASH_TYPE_NAME, FHASH_TYPE_ITERATOR_NAME, and +! | FHASH_TYPE_KV_TYPE_NAME. ! | ! FHASH_MODULE_NAME | The name of the module that encapsulates the FHASH ! | types and functionality @@ -17,6 +18,8 @@ ! FHASH_TYPE_ITERATOR_NAME | The name of the FHASH type that can iterate through ! | the whole FHASH ! | +! FHASH_TYPE_KV_TYPE_NAME | The name of the type that stores a key/value pair +! | ! KEY_USE | (optional) A use statement that is required to use ! | a specific type as a key for the FHASH ! KEY_TYPE | The type of the keys. May require KEY_USE to be @@ -38,26 +41,27 @@ #endif #ifdef SHORTNAME -#undef FHASH_MODULE_NAME -#undef FHASH_TYPE_NAME -#undef FHASH_TYPE_ITERATOR_NAME - -#ifdef __GFORTRAN__ -#define PASTE(a) a -#define CONCAT(a,b) PASTE(a)b -#else -#define PASTE(a,b) a ## b -#define CONCAT(a,b) PASTE(a,b) -#endif -#define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) -#define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) -#define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) +# undef FHASH_MODULE_NAME +# undef FHASH_TYPE_NAME +# undef FHASH_TYPE_ITERATOR_NAME +# undef FHASH_TYPE_KV_TYPE_NAME + +# ifdef __GFORTRAN__ +# define PASTE(a) a +# define CONCAT(a,b) PASTE(a)b +# else +# define PASTE(a,b) a ## b +# define CONCAT(a,b) PASTE(a,b) +# endif +# define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) +# define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) +# define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) #endif #ifdef VALUE_POINTER -#define VALUE_ASSIGNMENT => +# define VALUE_ASSIGNMENT => #else -#define VALUE_ASSIGNMENT = +# define VALUE_ASSIGNMENT = #endif ! Not all compilers implement finalization: @@ -89,14 +93,15 @@ module FHASH_MODULE_NAME public :: FHASH_TYPE_NAME public :: FHASH_TYPE_ITERATOR_NAME + public :: FHASH_TYPE_KV_TYPE_NAME - type kv_type + type :: FHASH_TYPE_KV_TYPE_NAME KEY_TYPE :: key VALUE_TYPE :: value end type - type node_type - type(kv_type), allocatable :: kv + type :: node_type + type(FHASH_TYPE_KV_TYPE_NAME), allocatable :: kv type(node_type), pointer :: next => null() contains From 1f3d1133597e2c3ad8252cbb49a0abfadf2cdc34 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 10:53:18 +0100 Subject: [PATCH 50/74] added hash: i2char --- fhash_modules.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/fhash_modules.f90 b/fhash_modules.f90 index 8c5c64d..eb3290a 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -1,3 +1,8 @@ +#define KEY_TYPE integer +#define VALUE_TYPE character(10) +#define SHORTNAME i2char +#include "fhash.f90" + ! Define the module for the key type. module ints_module From 12a5f194943bd6d12afb0318a12fe57cd7f57848 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 10:53:42 +0100 Subject: [PATCH 51/74] added "as_list" method to hash --- fhash.f90 | 21 +++++++++++++++++++++ fhash_test.f90 | 26 ++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) diff --git a/fhash.f90 b/fhash.f90 index 9091dfc..045a643 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -56,6 +56,7 @@ # define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) # define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) # define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) +# define FHASH_TYPE_KV_TYPE_NAME CONCAT(fhash_type_kv__,SHORTNAME) #endif #ifdef VALUE_POINTER @@ -170,6 +171,9 @@ module FHASH_MODULE_NAME ! Remove the value with the given key. procedure, non_overridable, public :: remove + ! Get the key/value pairs as a list: + procedure, non_overridable, public :: as_list + ! Return the accumalated storage size of an fhash, including the underlying pointers. ! Takes the bit size of a key-value pair as an argument. procedure, non_overridable, public :: deep_storage_size => fhash_deep_storage_size @@ -443,6 +447,23 @@ recursive subroutine node_remove(this, key, success, last) endif end subroutine + subroutine as_list(this, kv_list) + class(FHASH_TYPE_NAME), target, intent(in) :: this + type(FHASH_TYPE_KV_TYPE_NAME), allocatable, intent(out) :: kv_list(:) + + integer :: i, n + type(FHASH_TYPE_ITERATOR_NAME) :: iter + integer :: iter_stat + + n = this%key_count() + allocate(kv_list(n)) + call iter%begin(this) + do i = 1, n + call iter%next(kv_list(i)%key, kv_list(i)%value, iter_stat) + call assert(iter_stat == 0, "as_list: internal error: iterator stopped unexpectedly") + enddo + end subroutine + impure elemental subroutine deepcopy_fhash(lhs, rhs) class(FHASH_TYPE_NAME), intent(out) :: lhs type(FHASH_TYPE_NAME), intent(in) :: rhs diff --git a/fhash_test.f90 b/fhash_test.f90 index cb74fa5..d7f7c8c 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -5,6 +5,31 @@ module tests_mod implicit none contains + subroutine test_as_list + use fhash_module__i2char + + type(fhash_type__i2char) :: h + type(fhash_type_kv__i2char), allocatable :: kv_list(:) + character(10) :: val + integer :: i + logical :: success + + call h%reserve(3) + call h%set(1, "one ") + call h%set(0, "zero ") + call h%set(4, "four ") + call h%set(7, "seven ") + + call h%as_list(kv_list) + call assert(allocated(kv_list), "kv_list not allocated") + call assert(size(kv_list) == 4, "kv_list has bad size") + do i = 1, size(kv_list) + call h%get(kv_list(i)%key, val, success) + call assert(success, "key in list was not in hash") + call assert(val == kv_list(i)%value, "bad value in list") + enddo + end subroutine + subroutine test_deep_storage_size() type(fhash_type__ints_double) :: h type(ints_type) :: key @@ -119,6 +144,7 @@ program fhash_test call test_insert_and_get_int_ints_ptr() call test_insert_get_and_remove_int_ints_ptr() call test_iterate() + call test_as_list() call test_deep_storage_size() call test_assignment() From 93920496b7ca574bef532b4c6f3259bd720a38e1 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 11:28:24 +0100 Subject: [PATCH 52/74] added "as_sorted_list" method to hash; FAILS on WSL on Windows?! - based on qsort from C standard library --- Makefile | 3 ++- fhash.f90 | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++ fhash_test.f90 | 20 ++++++++++++++++ 3 files changed, 86 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 1bf5ab8..e037082 100644 --- a/Makefile +++ b/Makefile @@ -10,6 +10,7 @@ FFLAGS_BASIC += -Wunused-parameter FFLAGS_BASIC += -Wno-maybe-uninitialized -Wno-unused-dummy-argument -Wno-error=return-type FFLAGS_BASIC += -Wno-unused-function FFLAGS_BASIC += -Wno-conversion +FFLAGS_BASIC += -Wno-implicit-interface -Wno-strict-overflow # implicit interface is necessary for calling qsort with general types. Conversions from/to C ints are harmless. FFLAGS_DEVEL = -O0 -fcheck=all -fbounds-check -Warray-bounds -Wstrict-overflow=5 -Wunderflow -ffpe-trap=invalid,zero,overflow # FFLAGS_DEVEL += -ftrapv @@ -19,7 +20,7 @@ FFLAGS_RELEASE = -O3 # FFLAGS_BASIC += -Wdo-subscript -std=f2018 -Wfrontend-loop-interchange # FFLAGS_DEVEL += -fsanitize-address-use-after-scope -FFLAGS = $(FFLAGS_BASIC) $(FFLAGS_DEVEL) +FFLAGS = $(FFLAGS_DEVEL) $(FFLAGS_BASIC) .PHONY: all test clean ref diff --git a/fhash.f90 b/fhash.f90 index 045a643..4e93bf2 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -173,6 +173,7 @@ module FHASH_MODULE_NAME ! Get the key/value pairs as a list: procedure, non_overridable, public :: as_list + procedure, non_overridable, public :: as_sorted_list ! Return the accumalated storage size of an fhash, including the underlying pointers. ! Takes the bit size of a key-value pair as an argument. @@ -464,6 +465,31 @@ subroutine as_list(this, kv_list) enddo end subroutine + subroutine as_sorted_list(this, kv_list, compare) + class(FHASH_TYPE_NAME), target, intent(in) :: this + type(FHASH_TYPE_KV_TYPE_NAME), allocatable, intent(out) :: kv_list(:) + interface + integer function compare(a, b) + import + implicit none + KEY_TYPE, intent(in) :: a, b + end function + end interface + + integer, allocatable :: perm(:) + + call this%as_list(kv_list) + perm = sorting_perm(kv_list, compare_kv) + kv_list = kv_list(perm) + + contains + integer function compare_kv(a, b) + type(FHASH_TYPE_KV_TYPE_NAME), intent(in) :: a, b + + compare_kv = compare(a%key, b%key) + end function + end subroutine + impure elemental subroutine deepcopy_fhash(lhs, rhs) class(FHASH_TYPE_NAME), intent(out) :: lhs type(FHASH_TYPE_NAME), intent(in) :: rhs @@ -648,6 +674,44 @@ subroutine assert(condition, msg) error stop endif end subroutine + + function sorting_perm(x, compare_x) result(f_perm) + use, intrinsic :: iso_c_binding + class(*), intent(in) :: x(:) + integer, external :: compare_x + integer, allocatable :: f_perm(:) + + interface + subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") + ! The function pointer has the interface + ! int(*compar)(const void *, const void *) + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr), value :: array + integer(c_size_t), value :: elem_count + integer(c_size_t), value :: elem_size + type(c_funptr), value :: compare + end subroutine + end interface + integer(c_int) :: i + integer(c_int), allocatable, target :: perm(:) + + perm = [(i, i = 1_c_int, size(x, kind=c_int))] + if (size(x) > 0) call c_qsort(c_loc(perm(1)), size(x, kind=c_size_t), c_sizeof(perm(1)), c_funloc(compare_x_at_idx)) + f_perm = int(perm) + + contains + integer(c_int) function compare_x_at_idx(c_a, c_b) bind(C) + type(c_ptr), value :: c_a, c_b + + integer, pointer :: f_a, f_b + + call c_f_pointer(c_a, f_a) + call c_f_pointer(c_b, f_b) + + compare_x_at_idx = int(compare_x(x(f_a), x(f_b)), kind=c_int) + end function + end function end module #undef _FINAL_IS_IMPLEMENTED diff --git a/fhash_test.f90 b/fhash_test.f90 index d7f7c8c..b77a116 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -15,10 +15,13 @@ subroutine test_as_list logical :: success call h%reserve(3) + call h%set(1, "one (typo)") call h%set(1, "one ") call h%set(0, "zero ") call h%set(4, "four ") call h%set(7, "seven ") + + call assert(h%get_ptr(1) == "one", 'expected h%get_ptr(1) == "one"') call h%as_list(kv_list) call assert(allocated(kv_list), "kv_list not allocated") @@ -28,6 +31,23 @@ subroutine test_as_list call assert(success, "key in list was not in hash") call assert(val == kv_list(i)%value, "bad value in list") enddo + + call h%as_sorted_list(kv_list, compare_ints) + call assert(allocated(kv_list), "sorted kv_list not allocated") + call assert(size(kv_list) == 4, "sorted kv_list has bad size") + do i = 1, size(kv_list) + call h%get(kv_list(i)%key, val, success) + call assert(success, "key in sorted list was not in hash") + call assert(val == kv_list(i)%value, "bad value in sorted list") + enddo + call assert(kv_list(2:)%key - kv_list(:size(kv_list)-1)%key > 0, "sorted list should be strictly increasing") + + contains + integer function compare_ints(a, b) + integer, intent(in) :: a, b + + compare_ints = a - b + end function end subroutine subroutine test_deep_storage_size() From d5994a9d4cb97dcd8767397476cdb43e795c099b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 14:00:44 +0100 Subject: [PATCH 53/74] FIX sorting on WSL on Windows by not passing pointer to contained procedures --- fhash.f90 | 90 ++++++++++++++++++++++++++++++-------------------- fhash_test.f90 | 11 +++--- 2 files changed, 59 insertions(+), 42 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 4e93bf2..88c96fb 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -59,6 +59,10 @@ # define FHASH_TYPE_KV_TYPE_NAME CONCAT(fhash_type_kv__,SHORTNAME) #endif +! For some bizar reason both gfortran-10 and ifort-2021.4 fail to compile, unless +! this function has a unique name for every time that this file is included: +#define __COMPARE_AT_IDX CONCAT(fhash_type_compare__,SHORTNAME) + #ifdef VALUE_POINTER # define VALUE_ASSIGNMENT => #else @@ -214,7 +218,17 @@ module FHASH_MODULE_NAME module procedure :: scalar_all end interface - contains + interface + integer function compare_keys_i(a, b) + import + implicit none + KEY_TYPE, intent(in) :: a, b + end function + end interface + procedure(compare_keys_i), pointer :: global_compare_ptr => null() + type(FHASH_TYPE_KV_TYPE_NAME), pointer :: global_sorted_kv_list_ptr(:) => null() + +contains logical function keys_equal(a, b) KEY_TYPE, intent(in) :: a, b @@ -467,27 +481,23 @@ subroutine as_list(this, kv_list) subroutine as_sorted_list(this, kv_list, compare) class(FHASH_TYPE_NAME), target, intent(in) :: this - type(FHASH_TYPE_KV_TYPE_NAME), allocatable, intent(out) :: kv_list(:) - interface - integer function compare(a, b) - import - implicit none - KEY_TYPE, intent(in) :: a, b - end function - end interface + type(FHASH_TYPE_KV_TYPE_NAME), target, allocatable, intent(out) :: kv_list(:) + procedure(compare_keys_i) :: compare integer, allocatable :: perm(:) call this%as_list(kv_list) - perm = sorting_perm(kv_list, compare_kv) - kv_list = kv_list(perm) - contains - integer function compare_kv(a, b) - type(FHASH_TYPE_KV_TYPE_NAME), intent(in) :: a, b + call assert(.not. (associated(global_compare_ptr) .or. associated(global_sorted_kv_list_ptr)), & + "It looks like I am already sorting, and this is not thread-safe.") - compare_kv = compare(a%key, b%key) - end function + global_compare_ptr => compare + global_sorted_kv_list_ptr => kv_list + perm = sorting_perm() + kv_list = kv_list(perm) + + global_compare_ptr => null() + global_sorted_kv_list_ptr => null() end subroutine impure elemental subroutine deepcopy_fhash(lhs, rhs) @@ -675,12 +685,27 @@ subroutine assert(condition, msg) endif end subroutine - function sorting_perm(x, compare_x) result(f_perm) + integer(c_int) function __COMPARE_AT_IDX(c_a, c_b) bind(C) + use, intrinsic :: iso_c_binding, only: c_int, c_ptr, c_f_pointer + + type(c_ptr), value :: c_a, c_b + + integer(c_int), pointer :: f_a, f_b + + call c_f_pointer(c_a, f_a) + call c_f_pointer(c_b, f_b) + __COMPARE_AT_IDX = int(global_compare_ptr(global_sorted_kv_list_ptr(f_a)%key, & + global_sorted_kv_list_ptr(f_b)%key), kind=c_int) + end function + + function sorting_perm() result(f_perm) use, intrinsic :: iso_c_binding - class(*), intent(in) :: x(:) - integer, external :: compare_x + integer, allocatable :: f_perm(:) + integer(c_int) :: i, n + integer(c_int), allocatable, target :: perm(:) + type(c_funptr) :: fun interface subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") ! The function pointer has the interface @@ -693,29 +718,21 @@ subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") type(c_funptr), value :: compare end subroutine end interface - integer(c_int) :: i - integer(c_int), allocatable, target :: perm(:) - perm = [(i, i = 1_c_int, size(x, kind=c_int))] - if (size(x) > 0) call c_qsort(c_loc(perm(1)), size(x, kind=c_size_t), c_sizeof(perm(1)), c_funloc(compare_x_at_idx)) - f_perm = int(perm) - - contains - integer(c_int) function compare_x_at_idx(c_a, c_b) bind(C) - type(c_ptr), value :: c_a, c_b - - integer, pointer :: f_a, f_b + call assert(associated(global_sorted_kv_list_ptr) .and. associated(global_compare_ptr), & + "internal error: global sorting state has not been set yet") - call c_f_pointer(c_a, f_a) - call c_f_pointer(c_b, f_b) - - compare_x_at_idx = int(compare_x(x(f_a), x(f_b)), kind=c_int) - end function + n = size(global_sorted_kv_list_ptr, kind=c_int) + perm = [(i, i = 1_c_int, n)] + fun = c_funloc(__COMPARE_AT_IDX) + if (n > 0_c_int) call c_qsort(c_loc(perm(1)), int(n, kind=c_size_t), c_sizeof(perm(1)), fun) + f_perm = int(perm) end function end module #undef _FINAL_IS_IMPLEMENTED #undef _FINAL_TYPEORCLASS +#undef __COMPARE_AT_IDX #undef KEY_TYPE #undef KEYS_EQUAL_FUNC #undef VALUE_TYPE @@ -724,6 +741,7 @@ integer(c_int) function compare_x_at_idx(c_a, c_b) bind(C) #undef FHASH_TYPE_NAME #undef HASH_FUNC #undef FHASH_TYPE_ITERATOR_NAME +#undef FHASH_TYPE_KV_TYPE_NAME #undef SHORTNAME #undef CONCAT -#undef PASTE \ No newline at end of file +#undef PASTE diff --git a/fhash_test.f90 b/fhash_test.f90 index b77a116..461bc37 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -41,14 +41,13 @@ subroutine test_as_list call assert(val == kv_list(i)%value, "bad value in sorted list") enddo call assert(kv_list(2:)%key - kv_list(:size(kv_list)-1)%key > 0, "sorted list should be strictly increasing") + end subroutine - contains - integer function compare_ints(a, b) - integer, intent(in) :: a, b + integer function compare_ints(a, b) + integer, intent(in) :: a, b - compare_ints = a - b - end function - end subroutine + compare_ints = a - b + end function subroutine test_deep_storage_size() type(fhash_type__ints_double) :: h From 693daa1ab5a87b9991de08f4bd1e20c764467391 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 14:10:54 +0100 Subject: [PATCH 54/74] Make "SHORTNAME" macro mandatory --- benchmark.f90 | 10 +++------ fhash.f90 | 53 ++++++++++++++++------------------------------- fhash_modules.f90 | 6 +++--- 3 files changed, 24 insertions(+), 45 deletions(-) diff --git a/benchmark.f90 b/benchmark.f90 index e14b909..c32a356 100644 --- a/benchmark.f90 +++ b/benchmark.f90 @@ -1,13 +1,9 @@ #define KEY_ARRAY_SIZE 2 -#define FHASH_MODULE_NAME int_intsptr_fhash_mod -#define FHASH_TYPE_NAME int_intsptr_fhash_type -#define FHASH_TYPE_ITERATOR_NAME int_intsptr_fhash_iter_type +#define SHORTNAME int2real #define KEY_TYPE integer, dimension(KEY_ARRAY_SIZE) #define VALUE_TYPE real(real64) #define VALUE_USE use, intrinsic :: iso_fortran_env, only: real64 -! #define VALUE_TYPE_INIT null() -! #define VALUE_POINTER #include "fhash.f90" program test_benchmark @@ -17,11 +13,11 @@ program test_benchmark contains subroutine benchmark(n_ints, n_keys) - use int_intsptr_fhash_mod + use fhash_module__int2real integer, intent(in) :: n_ints, n_keys - type(int_intsptr_fhash_type) :: h + type(fhash_type__int2real) :: h integer :: key(n_ints) integer :: i, j real :: t0, t1, t2 diff --git a/fhash.f90 b/fhash.f90 index 88c96fb..027206d 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -6,19 +6,7 @@ ! ! #define | meaning ! --------------------------------+----------------------------------------------------- -! SHORTNAME | (optional) The name of the type this FHASH table is -! | for. If set, it overrides all settings that have -! | have possibly been made for FHASH_MODULE_NAME, -! | FHASH_TYPE_NAME, FHASH_TYPE_ITERATOR_NAME, and -! | FHASH_TYPE_KV_TYPE_NAME. -! | -! FHASH_MODULE_NAME | The name of the module that encapsulates the FHASH -! | types and functionality -! FHASH_TYPE_NAME | The name of the actual FHASH type -! FHASH_TYPE_ITERATOR_NAME | The name of the FHASH type that can iterate through -! | the whole FHASH -! | -! FHASH_TYPE_KV_TYPE_NAME | The name of the type that stores a key/value pair +! SHORTNAME | The name of the type of FHASH table. ! | ! KEY_USE | (optional) A use statement that is required to use ! | a specific type as a key for the FHASH @@ -40,24 +28,17 @@ ! | anywhere, it is configured based on VALUE_POINTER #endif -#ifdef SHORTNAME -# undef FHASH_MODULE_NAME -# undef FHASH_TYPE_NAME -# undef FHASH_TYPE_ITERATOR_NAME -# undef FHASH_TYPE_KV_TYPE_NAME - -# ifdef __GFORTRAN__ -# define PASTE(a) a -# define CONCAT(a,b) PASTE(a)b -# else -# define PASTE(a,b) a ## b -# define CONCAT(a,b) PASTE(a,b) -# endif -# define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) -# define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) -# define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) -# define FHASH_TYPE_KV_TYPE_NAME CONCAT(fhash_type_kv__,SHORTNAME) +#ifdef __GFORTRAN__ +# define PASTE(a) a +# define CONCAT(a,b) PASTE(a)b +#else +# define PASTE(a,b) a ## b +# define CONCAT(a,b) PASTE(a,b) #endif +#define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) +#define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) +#define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) +#define FHASH_TYPE_KV_TYPE_NAME CONCAT(fhash_type_kv__,SHORTNAME) ! For some bizar reason both gfortran-10 and ifort-2021.4 fail to compile, unless ! this function has a unique name for every time that this file is included: @@ -493,6 +474,7 @@ subroutine as_sorted_list(this, kv_list, compare) global_compare_ptr => compare global_sorted_kv_list_ptr => kv_list + allocate(perm(size(kv_list))) perm = sorting_perm() kv_list = kv_list(perm) @@ -730,6 +712,12 @@ subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") end function end module +#undef SHORTNAME +#undef FHASH_MODULE_NAME +#undef FHASH_TYPE_NAME +#undef FHASH_TYPE_ITERATOR_NAME +#undef FHASH_TYPE_KV_TYPE_NAME +#undef HASH_FUNC #undef _FINAL_IS_IMPLEMENTED #undef _FINAL_TYPEORCLASS #undef __COMPARE_AT_IDX @@ -738,10 +726,5 @@ subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") #undef VALUE_TYPE #undef VALUE_TYPE_INIT #undef VALUE_ASSIGNMENT -#undef FHASH_TYPE_NAME -#undef HASH_FUNC -#undef FHASH_TYPE_ITERATOR_NAME -#undef FHASH_TYPE_KV_TYPE_NAME -#undef SHORTNAME #undef CONCAT #undef PASTE diff --git a/fhash_modules.f90 b/fhash_modules.f90 index eb3290a..ce22414 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -1,6 +1,6 @@ +#define SHORTNAME i2char #define KEY_TYPE integer #define VALUE_TYPE character(10) -#define SHORTNAME i2char #include "fhash.f90" ! Define the module for the key type. @@ -61,6 +61,7 @@ function ints_equal(lhs, rhs) end module ints_module ! Define the macros needed by fhash and include fhash.f90 +#define SHORTNAME ints_double #define KEY_USE use ints_module #define KEY_TYPE type(ints_type) #define KEYS_EQUAL_FUNC ints_equal @@ -68,15 +69,14 @@ end module ints_module #define VALUE_TYPE real(real64) #define HASH_FUNC hash_value #define VALUE_TYPE_INIT 0.0 -#define SHORTNAME ints_double #include "fhash.f90" ! Define the macros needed by fhash and include fhash.f90 +#define SHORTNAME int_ints_ptr #define KEY_TYPE integer #define VALUE_USE use ints_module #define VALUE_TYPE type(ints_type), pointer !#define VALUE_TYPE_INIT null() -#define SHORTNAME int_ints_ptr #define VALUE_POINTER #ifdef VALUE_TYPE_INIT #define CHECK_ITERATOR_VALUE From a96041d3c36561b54da0d27ab473a32b65102ab1 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 14:12:19 +0100 Subject: [PATCH 55/74] Makefile: added comments for ifort --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index e037082..5ba0e23 100644 --- a/Makefile +++ b/Makefile @@ -20,6 +20,10 @@ FFLAGS_RELEASE = -O3 # FFLAGS_BASIC += -Wdo-subscript -std=f2018 -Wfrontend-loop-interchange # FFLAGS_DEVEL += -fsanitize-address-use-after-scope +# FC = ifort +# FFLAGS_BASIC = -g -traceback -cpp +# FFLAGS_DEVEL = -O0 + FFLAGS = $(FFLAGS_DEVEL) $(FFLAGS_BASIC) .PHONY: all test clean ref From f89728b01aa871437d43abf8fb4dc962b7365d12 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 14:28:08 +0100 Subject: [PATCH 56/74] less verbose type names --- README.md | 2 ++ benchmark.f90 | 6 +++--- fhash.f90 | 14 +++++++------- fhash_modules.f90 | 6 +++--- fhash_test.f90 | 36 ++++++++++++++++++------------------ 5 files changed, 33 insertions(+), 31 deletions(-) diff --git a/README.md b/README.md index f3aa630..012b148 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,8 @@ Fast hash map implementation in fortran ## Description Implemention of the GCC hashmap structure in Fortran. It supports any types of keys and values, as long as you set the following macros: +* `FHASH_NAME`; + * `KEY_TYPE` and `VALUE_TYPE` with corresponding use statements `KEY_USE` and `VALUE_USE`, and, optionally, diff --git a/benchmark.f90 b/benchmark.f90 index c32a356..197a7ed 100644 --- a/benchmark.f90 +++ b/benchmark.f90 @@ -1,6 +1,6 @@ #define KEY_ARRAY_SIZE 2 -#define SHORTNAME int2real +#define FHASH_NAME int2real #define KEY_TYPE integer, dimension(KEY_ARRAY_SIZE) #define VALUE_TYPE real(real64) #define VALUE_USE use, intrinsic :: iso_fortran_env, only: real64 @@ -13,11 +13,11 @@ program test_benchmark contains subroutine benchmark(n_ints, n_keys) - use fhash_module__int2real + use int2real_mod integer, intent(in) :: n_ints, n_keys - type(fhash_type__int2real) :: h + type(int2real_t) :: h integer :: key(n_ints) integer :: i, j real :: t0, t1, t2 diff --git a/fhash.f90 b/fhash.f90 index 027206d..f311309 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -6,7 +6,7 @@ ! ! #define | meaning ! --------------------------------+----------------------------------------------------- -! SHORTNAME | The name of the type of FHASH table. +! FHASH_NAME | The name of the type of FHASH table. ! | ! KEY_USE | (optional) A use statement that is required to use ! | a specific type as a key for the FHASH @@ -35,14 +35,14 @@ # define PASTE(a,b) a ## b # define CONCAT(a,b) PASTE(a,b) #endif -#define FHASH_MODULE_NAME CONCAT(fhash_module__,SHORTNAME) -#define FHASH_TYPE_NAME CONCAT(fhash_type__,SHORTNAME) -#define FHASH_TYPE_ITERATOR_NAME CONCAT(fhash_type_iterator__,SHORTNAME) -#define FHASH_TYPE_KV_TYPE_NAME CONCAT(fhash_type_kv__,SHORTNAME) +#define FHASH_MODULE_NAME CONCAT(FHASH_NAME,_mod) +#define FHASH_TYPE_NAME CONCAT(FHASH_NAME,_t) +#define FHASH_TYPE_ITERATOR_NAME CONCAT(FHASH_NAME,_iter_t) +#define FHASH_TYPE_KV_TYPE_NAME CONCAT(FHASH_NAME,_kv_t) ! For some bizar reason both gfortran-10 and ifort-2021.4 fail to compile, unless ! this function has a unique name for every time that this file is included: -#define __COMPARE_AT_IDX CONCAT(fhash_type_compare__,SHORTNAME) +#define __COMPARE_AT_IDX CONCAT(fhash_type_compare__,FHASH_NAME) #ifdef VALUE_POINTER # define VALUE_ASSIGNMENT => @@ -712,7 +712,7 @@ subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") end function end module -#undef SHORTNAME +#undef FHASH_NAME #undef FHASH_MODULE_NAME #undef FHASH_TYPE_NAME #undef FHASH_TYPE_ITERATOR_NAME diff --git a/fhash_modules.f90 b/fhash_modules.f90 index ce22414..e97863f 100644 --- a/fhash_modules.f90 +++ b/fhash_modules.f90 @@ -1,4 +1,4 @@ -#define SHORTNAME i2char +#define FHASH_NAME i2char #define KEY_TYPE integer #define VALUE_TYPE character(10) #include "fhash.f90" @@ -61,7 +61,7 @@ function ints_equal(lhs, rhs) end module ints_module ! Define the macros needed by fhash and include fhash.f90 -#define SHORTNAME ints_double +#define FHASH_NAME ints_double #define KEY_USE use ints_module #define KEY_TYPE type(ints_type) #define KEYS_EQUAL_FUNC ints_equal @@ -72,7 +72,7 @@ end module ints_module #include "fhash.f90" ! Define the macros needed by fhash and include fhash.f90 -#define SHORTNAME int_ints_ptr +#define FHASH_NAME int_ints_ptr #define KEY_TYPE integer #define VALUE_USE use ints_module #define VALUE_TYPE type(ints_type), pointer diff --git a/fhash_test.f90 b/fhash_test.f90 index 461bc37..da04be0 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -1,15 +1,15 @@ module tests_mod use ints_module - use fhash_module__ints_double + use ints_double_mod use, intrinsic :: iso_fortran_env implicit none contains subroutine test_as_list - use fhash_module__i2char + use i2char_mod - type(fhash_type__i2char) :: h - type(fhash_type_kv__i2char), allocatable :: kv_list(:) + type(i2char_t) :: h + type(i2char_kv_t), allocatable :: kv_list(:) character(10) :: val integer :: i logical :: success @@ -50,7 +50,7 @@ integer function compare_ints(a, b) end function subroutine test_deep_storage_size() - type(fhash_type__ints_double) :: h + type(ints_double_t) :: h type(ints_type) :: key integer :: i @@ -75,7 +75,7 @@ subroutine test_deep_storage_size() end subroutine subroutine test_assignment() - type(fhash_type__ints_double) :: a, b, c + type(ints_double_t) :: a, b, c type(ints_type) :: keys(100) real(real64) :: values(size(keys)) @@ -111,9 +111,9 @@ subroutine test_assignment() call check_kv(b) contains subroutine check_kv(fhash) - type(fhash_type__ints_double), intent(in) :: fhash + type(ints_double_t), intent(in) :: fhash - type(fhash_type_iterator__ints_double) :: iter + type(ints_double_iter_t) :: iter type(ints_type) :: key real(real64) :: val integer :: i @@ -151,8 +151,8 @@ impure elemental subroutine assert(condition, msg) program fhash_test use, intrinsic :: iso_fortran_env - use fhash_module__ints_double - use fhash_module__int_ints_ptr + use ints_double_mod + use int_ints_ptr_mod use ints_module use tests_mod implicit none @@ -171,19 +171,19 @@ program fhash_test contains subroutine test_contructor() - type(fhash_type__ints_double) h + type(ints_double_t) h if (h%key_count() /= 0) stop 'expect no keys' end subroutine subroutine test_reserve() - type(fhash_type__ints_double) :: h + type(ints_double_t) :: h call h%reserve(3) call assert(h%bucket_count() == 5, 'expected to reserve 5 buckets') end subroutine subroutine test_insert_and_get_ints_double() - type(fhash_type__ints_double) :: h + type(ints_double_t) :: h type(ints_type) :: key real(real64) :: value real(real64), pointer :: val_ptr @@ -219,7 +219,7 @@ subroutine test_insert_and_get_ints_double() end subroutine subroutine test_insert_and_get_int_ints_ptr() - type(fhash_type__int_ints_ptr) :: h + type(int_ints_ptr_t) :: h type(ints_type), target :: value type(ints_type), pointer :: value_ptr, value_ptr2, value_ptr3 logical :: success @@ -237,12 +237,12 @@ subroutine test_insert_and_get_int_ints_ptr() end subroutine subroutine test_insert_get_and_remove_int_ints_ptr() - type(fhash_type__int_ints_ptr) :: h + type(int_ints_ptr_t) :: h integer, parameter :: num_values = 50 type(ints_type), pointer :: pValues(:), pValue logical :: success integer :: i, key, status - type(fhash_type_iterator__int_ints_ptr) :: it + type(int_ints_ptr_iter_t) :: it ! prepare allocate(pValues(num_values)) @@ -317,8 +317,8 @@ subroutine test_insert_get_and_remove_int_ints_ptr() end subroutine subroutine test_iterate() - type(fhash_type__ints_double) :: h - type(fhash_type_iterator__ints_double) :: it + type(ints_double_t) :: h + type(ints_double_iter_t) :: it type(ints_type) :: key real(real64) :: value integer :: i, j From e6b47fa26619bef153f714f9a0389e6ac97ad203 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 5 Nov 2021 15:46:08 +0100 Subject: [PATCH 57/74] delted redundant "#undef" --- fhash.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index f311309..0d763a0 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -62,7 +62,6 @@ #endif module FHASH_MODULE_NAME -#undef FHASH_MODULE_NAME #ifdef KEY_USE KEY_USE From 22f65fbb6595901228f238e343ab1424193f05f7 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Tue, 9 Nov 2021 19:15:12 +0100 Subject: [PATCH 58/74] simplified node_set --- fhash.f90 | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 0d763a0..1424d58 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -90,11 +90,6 @@ module FHASH_MODULE_NAME type(node_type), pointer :: next => null() contains - ! If kv is not allocated, allocate and set to the key, value passed in. - ! If key is present and the same as the key passed in, overwrite the value. - ! Otherwise, defer to the next node (allocate if not allocated) - procedure, non_overridable :: node_set - ! If kv is not allocated, fail and return ! If key is present and node is first in bucket, set first node in bucket to ! the next node of first. Return success @@ -293,28 +288,31 @@ subroutine set(this, key, value) call assert(associated(this%buckets), "set: fhash has not been initialized") bucket_id = this%key2bucket(key) - call this%buckets(bucket_id)%node_set(key, value, is_new) + call node_set(this%buckets(bucket_id), key, value, is_new) if (is_new) this%n_keys = this%n_keys + 1 end subroutine recursive subroutine node_set(this, key, value, is_new) - class(node_type), intent(inout) :: this + ! If kv is not allocated, allocate and set to the key, value passed in. + ! If key is present and the same as the key passed in, overwrite the value. + ! Otherwise, defer to the next node (allocate if not allocated) + type(node_type), intent(inout) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, intent(in) :: value - logical, optional, intent(out) :: is_new + logical, intent(out) :: is_new if (.not. allocated(this%kv)) then allocate(this%kv) this%kv%key = key this%kv%value VALUE_ASSIGNMENT value - if (present(is_new)) is_new = .true. + is_new = .true. else if (keys_equal(this%kv%key, key)) then this%kv%value VALUE_ASSIGNMENT value - if (present(is_new)) is_new = .false. + is_new = .false. else if (.not. associated(this%next)) allocate(this%next) - call this%next%node_set(key, value, is_new) + call node_set(this%next, key, value, is_new) endif end subroutine From deda660eccb18a22e6ad62f61b6dec9576b4db3f Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 10 Nov 2021 07:43:53 +0100 Subject: [PATCH 59/74] added "autoval" option to "get_ptr" --- fhash.f90 | 60 +++++++++++++++++++++++++++++++++++++++++++++----- fhash_test.f90 | 39 ++++++++++++++++++++++++++++++++ 2 files changed, 94 insertions(+), 5 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 1424d58..2cd8734 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -144,7 +144,9 @@ module FHASH_MODULE_NAME procedure, non_overridable, public :: get #ifndef VALUE_POINTER - procedure, non_overridable, public :: get_ptr + generic :: get_ptr => get_ptr_or_autoval, get_ptr_or_null + procedure, non_overridable, public :: get_ptr_or_null + procedure, non_overridable, public :: get_ptr_or_autoval #endif ! Remove the value with the given key. @@ -354,7 +356,7 @@ recursive subroutine node_get(this, key, value, success) end subroutine #ifndef VALUE_POINTER - function get_ptr(this, key) result(value) + function get_ptr_or_null(this, key) result(value) class(FHASH_TYPE_NAME), intent(in) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, pointer :: value @@ -368,10 +370,10 @@ function get_ptr(this, key) result(value) call assert(1 <= bucket_id .and. bucket_id <= size(this%buckets), "get: fhash has not been initialized") bucket => this%buckets(bucket_id) - value => node_get_ptr(bucket, key) + value => node_get_ptr_or_null(bucket, key) end function - recursive function node_get_ptr(this, key) result(value) + recursive function node_get_ptr_or_null(this, key) result(value) type(node_type), target, intent(in) :: this KEY_TYPE, intent(in) :: key VALUE_TYPE, pointer :: value @@ -383,9 +385,57 @@ recursive function node_get_ptr(this, key) result(value) else if (.not. associated(this%next)) then value => null() else - value => node_get_ptr(this%next, key) + value => node_get_ptr_or_null(this%next, key) endif end function + + function get_ptr_or_autoval(this, key, autoval) result(value) + class(FHASH_TYPE_NAME), intent(inout) :: this + KEY_TYPE, intent(in) :: key + VALUE_TYPE, intent(in) :: autoval + VALUE_TYPE, pointer :: value + + integer :: bucket_id + type(node_type), pointer :: bucket + logical :: is_new + + call assert(associated(this%buckets), "get: fhash has not been initialized") + + bucket_id = this%key2bucket(key) + call assert(1 <= bucket_id .and. bucket_id <= size(this%buckets), "get: fhash has not been initialized") + bucket => this%buckets(bucket_id) + + call node_get_ptr_or_autoval(bucket, key, value, is_new, autoval) + if (is_new) this%n_keys = this%n_keys + 1 + end function + + recursive subroutine node_get_ptr_or_autoval(this, key, value, is_new, autoval) + type(node_type), target, intent(inout) :: this + KEY_TYPE, intent(in) :: key + VALUE_TYPE, pointer, intent(out) :: value + logical, intent(out) :: is_new + VALUE_TYPE, intent(in) :: autoval + + if (.not. allocated(this%kv)) then + allocate(this%kv) + this%kv%key = key + this%kv%value = autoval + value => this%kv%value + is_new = .true. + else if (keys_equal(this%kv%key, key)) then + value => this%kv%value + is_new = .false. + else if (.not. associated(this%next)) then + allocate(this%next) + allocate(this%next%kv) + this%next%kv%key = key + this%next%kv%value = autoval + value => this%next%kv%value + is_new = .true. + else + call node_get_ptr_or_autoval(this%next, key, value, is_new, autoval) + endif + end subroutine #endif subroutine remove(this, key, success) diff --git a/fhash_test.f90 b/fhash_test.f90 index da04be0..581e591 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -43,6 +43,44 @@ subroutine test_as_list call assert(kv_list(2:)%key - kv_list(:size(kv_list)-1)%key > 0, "sorted list should be strictly increasing") end subroutine + subroutine test_get_ptr() + use i2char_mod + + type(i2char_t) :: h + character(:), pointer :: c + type(i2char_kv_t), allocatable :: kv_list(:) + integer :: i + + call h%reserve(1) + + call h%set(7, "seven ") + + c => h%get_ptr(0) + call assert(.not. associated(c), "expected .not. associated(c)") + c => h%get_ptr(1) + call assert(.not. associated(c), "expected .not. associated(c)") + c => h%get_ptr(7) + call assert(associated(c), "expected associated(c)") + call assert(c == "seven", "exptected c == 'seven'") + + c(:) = 'new seven' + c => h%get_ptr(7) + call assert(associated(c), "expected associated(c)") + call assert(c == 'new seven', "expected c == 'new seven'") + + do i = 1, 3 + c => h%get_ptr(2, autoval='auto two ') + call assert(associated(c), "expected associated(c)") + call assert(c == 'auto two', "expected c == 'auto two'") + call assert(h%key_count() == 2, 'expected two keys in h') + enddo + + call h%as_sorted_list(kv_list, compare_ints) + call assert(size(kv_list) == 2, "expected size(kv_list) == 2") + call assert(kv_list%key == [2, 7], "keys should be [2, 7]") + call assert(kv_list%value == ['auto two ', 'new seven'], "test_get_ptr: bad values") + end subroutine + integer function compare_ints(a, b) integer, intent(in) :: a, b @@ -157,6 +195,7 @@ program fhash_test use tests_mod implicit none + call test_get_ptr() call test_contructor() call test_reserve() call test_insert_and_get_ints_double() From f2db64025540346303d571c87ba56cdefc502f6a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 10 Nov 2021 09:16:40 +0100 Subject: [PATCH 60/74] made "key_count" elemental --- fhash.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index 2cd8734..1672145 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -273,7 +273,7 @@ impure elemental subroutine reserve(this, n_buckets) enddo end subroutine - function key_count(this) + impure elemental function key_count(this) class(FHASH_TYPE_NAME), intent(in) :: this integer :: key_count From 2ab9cdff6f2fa12a0e0f2bf0b03f3ad9e862151a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 10 Nov 2021 11:44:51 +0100 Subject: [PATCH 61/74] made sort_kv_list public --- fhash.f90 | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 1672145..a839583 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -39,6 +39,7 @@ #define FHASH_TYPE_NAME CONCAT(FHASH_NAME,_t) #define FHASH_TYPE_ITERATOR_NAME CONCAT(FHASH_NAME,_iter_t) #define FHASH_TYPE_KV_TYPE_NAME CONCAT(FHASH_NAME,_kv_t) +#define FHASH_SORT_KV_NAME CONCAT(sort_,FHASH_NAME) ! For some bizar reason both gfortran-10 and ifort-2021.4 fail to compile, unless ! this function has a unique name for every time that this file is included: @@ -79,6 +80,8 @@ module FHASH_MODULE_NAME public :: FHASH_TYPE_NAME public :: FHASH_TYPE_ITERATOR_NAME public :: FHASH_TYPE_KV_TYPE_NAME + public :: FHASH_SORT_KV_NAME ! for convenience, because it's hard for the users to write a generic sort + ! (that circumvents the compiler bugs when passing pointers to internal functions to `qsort`) type :: FHASH_TYPE_KV_TYPE_NAME KEY_TYPE :: key @@ -512,19 +515,21 @@ subroutine as_sorted_list(this, kv_list, compare) type(FHASH_TYPE_KV_TYPE_NAME), target, allocatable, intent(out) :: kv_list(:) procedure(compare_keys_i) :: compare - integer, allocatable :: perm(:) - call this%as_list(kv_list) + call FHASH_SORT_KV_NAME(kv_list, compare) + end subroutine + + subroutine FHASH_SORT_KV_NAME(kv_list, compare) + type(FHASH_TYPE_KV_TYPE_NAME), target, intent(inout) :: kv_list(:) + procedure(compare_keys_i) :: compare call assert(.not. (associated(global_compare_ptr) .or. associated(global_sorted_kv_list_ptr)), & "It looks like I am already sorting, and this is not thread-safe.") - global_compare_ptr => compare global_sorted_kv_list_ptr => kv_list - allocate(perm(size(kv_list))) - perm = sorting_perm() - kv_list = kv_list(perm) + kv_list = kv_list(sorting_perm()) + global_compare_ptr => null() global_sorted_kv_list_ptr => null() end subroutine From 9cb0c369d2fabc369cca740302641f8941814cfa Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 11 Nov 2021 16:43:56 +0100 Subject: [PATCH 62/74] make passed dummy intent(out) in "reserver" --- fhash.f90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index a839583..84bcc7f 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -255,7 +255,7 @@ recursive function node_depth(this) result(depth) end function impure elemental subroutine reserve(this, n_buckets) - class(FHASH_TYPE_NAME), intent(inout) :: this + class(FHASH_TYPE_NAME), intent(out) :: this integer, intent(in) :: n_buckets integer :: i @@ -263,12 +263,12 @@ impure elemental subroutine reserve(this, n_buckets) & 28411, 57557, 116731, 236897, 480881, 976369,1982627, 4026031, & & 8175383, 16601593, 33712729, 68460391, 139022417, 282312799, & & 573292817, 1164186217, 2147483647] + integer, parameter :: n = size(sizes) - call assert(this%key_count() == 0, 'Cannot reserve when fhash is not empty.') - call assert(n_buckets >= 1, "I need at least one bucket.") - call assert(sizes(size(sizes)) >= n_buckets, "Did not expect to need this many buckets.") + call assert(sizes(2:) - sizes(:n-1) > 0, "PROGRAMMING ERROR: sizes should be strictly increasing") + call assert(sizes(n) >= n_buckets, "Did not expect to need this many buckets.") - do i = 1, size(sizes) + do i = 1, n if (sizes(i) >= n_buckets) then allocate(this%buckets(sizes(i))) exit @@ -708,7 +708,7 @@ logical function scalar_all(scal) scalar_all = scal end function - subroutine assert(condition, msg) + impure elemental subroutine assert(condition, msg) use, intrinsic :: iso_fortran_env, only: error_unit logical, intent(in) :: condition character(*), intent(in) :: msg From de048cb44e210d93e98c1a9b57dc75345b7900d6 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 11 Nov 2021 17:03:00 +0100 Subject: [PATCH 63/74] made clear more performant --- fhash.f90 | 70 ++++++++++++++++++++++++++----------------------------- 1 file changed, 33 insertions(+), 37 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 84bcc7f..b982ceb 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -104,22 +104,12 @@ module FHASH_MODULE_NAME ! Return the length of the linked list start from the current node. procedure, non_overridable :: node_depth - - ! Deallocate kv if allocated. - ! Call the clear method of the next node if the next pointer associated. - ! Deallocate and nullify the next pointer. - ! - ! Need separate finalizers because a resursive procedure cannot be elemental. -#ifdef _FINAL_IS_IMPLEMENTED - final :: clear_scalar_node - final :: clear_rank1_nodes -#else - ! Old `gfortran` versions think the passed dummy must be a scalar: - generic, public :: clear => clear_scalar_node - procedure, non_overridable, private :: clear_scalar_node - ! procedure, non_overridable, private :: clear_rank1_nodes -#endif - end type + + ! No FINAL procedure here, because it would have to be recursive (at least + ! implicitly, because it finalizes the 'next' pointer), and a recursive + ! procedure is not performant. + ! Fortunately this type is not public, and it gets deallocated when finalizing the fhash. + end type type FHASH_TYPE_NAME private @@ -590,8 +580,16 @@ recursive integer function node_deep_storage_size(node, keyval_ss) result(s) impure elemental subroutine clear(this) class(FHASH_TYPE_NAME), intent(inout) :: this + integer :: i + this%n_keys = 0 - if (associated(this%buckets)) deallocate(this%buckets) + if (associated(this%buckets)) then + do i = 1, size(this%buckets) + call clear_children(this%buckets(i)) + if (allocated(this%buckets(i)%kv)) deallocate(this%buckets(i)%kv) + enddo + deallocate(this%buckets) + endif end subroutine #ifdef _FINAL_IS_IMPLEMENTED @@ -602,6 +600,24 @@ impure elemental subroutine clear_final(this) end subroutine #endif + subroutine clear_children(node) + ! Not a recursive subroutine, because (i) this is much more performant, and + ! (ii) gfortran thinks that it cannot be both elemental and recursive. + _FINAL_TYPEORCLASS(node_type), intent(inout) :: node + + type(node_type), pointer :: prev, next + + if (.not. associated(node%next)) return + + prev => node%next + do + next => prev%next + deallocate(prev) + if (.not. associated(next)) exit + prev => next + enddo + end subroutine + integer function key2bucket(this, key) result(bucket_id) class(FHASH_TYPE_NAME), intent(in) :: this KEY_TYPE, intent(in) :: key @@ -616,26 +632,6 @@ integer function key2bucket(this, key) result(bucket_id) bucket_id = modulo(hash, size(this%buckets)) + 1 end function - - subroutine clear_rank1_nodes(nodes) - _FINAL_TYPEORCLASS(node_type), intent(inout) :: nodes(:) - - integer :: i - - do i = 1, size(nodes) - call clear_scalar_node(nodes(i)) - enddo - end subroutine - - recursive subroutine clear_scalar_node(node) - _FINAL_TYPEORCLASS(node_type), intent(inout) :: node - - if (associated(node%next)) then - call clear_scalar_node(node%next) - deallocate(node%next) - endif - end subroutine - subroutine begin(this, fhash_target) class(FHASH_TYPE_ITERATOR_NAME), intent(inout) :: this type(FHASH_TYPE_NAME), target, intent(in) :: fhash_target From 611cc71a54903fc5dbf93b730425dfb844c98f3a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 11 Nov 2021 17:49:13 +0100 Subject: [PATCH 64/74] Makefile: improved rules for benchmark --- Makefile | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 5ba0e23..1222bf8 100644 --- a/Makefile +++ b/Makefile @@ -20,13 +20,15 @@ FFLAGS_RELEASE = -O3 # FFLAGS_BASIC += -Wdo-subscript -std=f2018 -Wfrontend-loop-interchange # FFLAGS_DEVEL += -fsanitize-address-use-after-scope +# CPPC = icpc # FC = ifort # FFLAGS_BASIC = -g -traceback -cpp # FFLAGS_DEVEL = -O0 +# FFLAGS_RELEASE = -Ofast FFLAGS = $(FFLAGS_DEVEL) $(FFLAGS_BASIC) -.PHONY: all test clean ref +.PHONY: all test clean all: test @@ -34,13 +36,14 @@ test: fhash_modules fhash_test.f90 $(FC) $(FFLAGS) fhash_modules.f90 fhash_test.f90 -o fhash_test.out \ && ./fhash_test.out -benchmark: fhash_modules.f90 benchmark.f90 - $(FC) $(FFLAGS_BASIC) $(FFLAGS_RELEASE) benchmark.f90 -o fhash_benchmark.out && \ - $(CPPC) -std=c++11 -O3 benchmark.cc -o stl_benchmark.out && \ +benchmark: fhash_benchmark.out stl_benchmark.out ./fhash_benchmark.out && ./stl_benchmark.out -ref: benchmark.cc - g++ -O3 -std=c++14 benchmark.cc -o ref.out && ./ref.out +fhash_benchmark.out: fhash_modules.f90 benchmark.f90 + $(FC) $(FFLAGS_BASIC) $(FFLAGS_RELEASE) fhash_modules.f90 benchmark.f90 -o fhash_benchmark.out + +stl_benchmark.out: benchmark.cc + $(CPPC) -std=c++11 -O3 $< -o $@ clean: rm -rf *.mod *.o From dce2c78b1fc6c15a9a59fe3295771b50dfa1cd82 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 11 Nov 2021 18:00:11 +0100 Subject: [PATCH 65/74] simplified clear --- fhash.f90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index b982ceb..e4970ff 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -607,14 +607,12 @@ subroutine clear_children(node) type(node_type), pointer :: prev, next - if (.not. associated(node%next)) return - - prev => node%next + next => node%next do + if (.not. associated(next)) return + prev => next next => prev%next deallocate(prev) - if (.not. associated(next)) exit - prev => next enddo end subroutine From 930783da7b065042d4452ae47a1b72b096888770 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 11 Nov 2021 19:02:19 +0100 Subject: [PATCH 66/74] README: updated benchmark --- README.md | 43 ++++++++++++++----------------------------- 1 file changed, 14 insertions(+), 29 deletions(-) diff --git a/README.md b/README.md index 012b148..60deedf 100644 --- a/README.md +++ b/README.md @@ -18,40 +18,25 @@ and, optionally, ## Benchmarks -Here are the benchmarks between my Fortran implementation and GCC 4.8 standard library: +For -For 14 integer array as the key, double precision floating point as the value, 10M entries: +* key: integer array of size 2; -Fortran hash: +* value: double precision (64-bit) floating point; -> Insert: 1.80 s -> -> Clean: 1.70 s -> -> 1.59 GB +* 10M entries, -GCC unordered_map: +on -> Insert: 2.02 s -> -> Clean: 0.61 s -> -> 1.38 GB +* Intel(R) Core(TM) i7-6820HQ CPU @ 2.70GHz; -For 2 integer array as the key, double precision floating point as the value, 20M entries: +* Ubuntu 20.04.3 LTS, -Fortran hash: +I got -> Insert: 2.66 s -> -> Clean: 2.54 s -> -> 2.57 GB - -GCC unordered_map: - -> Insert: 3.60 s -> -> Clean: 1.07 s -> -> 2.16 GB \ No newline at end of file +| | | ifort 2021 | gfortran 9 | +|-----------|---------------|------------|------------| +| *insert* | **fhash** | 2.99 | 2.38 | +| | **C++ (STL)** | 2.80 | 2.69 | +| *clear* | **fhash** | 1.24 | 0.391 | +| | **C++ (STL)** | 0.37 | 0.328 | From d15677e3dc2cde87e732da2b9dcba338300693b0 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 12 Nov 2021 16:26:31 +0100 Subject: [PATCH 67/74] as_[sorted_]list does not take a dummy --- fhash.f90 | 9 +++++---- fhash_test.f90 | 15 +++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index e4970ff..aa11486 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -485,14 +485,15 @@ recursive subroutine node_remove(this, key, success, last) subroutine as_list(this, kv_list) class(FHASH_TYPE_NAME), target, intent(in) :: this - type(FHASH_TYPE_KV_TYPE_NAME), allocatable, intent(out) :: kv_list(:) + type(FHASH_TYPE_KV_TYPE_NAME), intent(out) :: kv_list(:) integer :: i, n type(FHASH_TYPE_ITERATOR_NAME) :: iter integer :: iter_stat - + n = this%key_count() - allocate(kv_list(n)) + call assert(size(kv_list) == n, "as_list: kv_list has a bad size") + call iter%begin(this) do i = 1, n call iter%next(kv_list(i)%key, kv_list(i)%value, iter_stat) @@ -502,7 +503,7 @@ subroutine as_list(this, kv_list) subroutine as_sorted_list(this, kv_list, compare) class(FHASH_TYPE_NAME), target, intent(in) :: this - type(FHASH_TYPE_KV_TYPE_NAME), target, allocatable, intent(out) :: kv_list(:) + type(FHASH_TYPE_KV_TYPE_NAME), target, intent(out) :: kv_list(:) procedure(compare_keys_i) :: compare call this%as_list(kv_list) diff --git a/fhash_test.f90 b/fhash_test.f90 index 581e591..135dce3 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -9,9 +9,10 @@ subroutine test_as_list use i2char_mod type(i2char_t) :: h - type(i2char_kv_t), allocatable :: kv_list(:) character(10) :: val integer :: i + integer, parameter :: n_uniq = 4 + type(i2char_kv_t) :: kv_list(n_uniq) logical :: success call h%reserve(3) @@ -20,22 +21,19 @@ subroutine test_as_list call h%set(0, "zero ") call h%set(4, "four ") call h%set(7, "seven ") - call assert(h%get_ptr(1) == "one", 'expected h%get_ptr(1) == "one"') call h%as_list(kv_list) - call assert(allocated(kv_list), "kv_list not allocated") - call assert(size(kv_list) == 4, "kv_list has bad size") - do i = 1, size(kv_list) + call assert(size(kv_list) == n_uniq, "kv_list has bad size") + do i = 1, n_uniq call h%get(kv_list(i)%key, val, success) call assert(success, "key in list was not in hash") call assert(val == kv_list(i)%value, "bad value in list") enddo call h%as_sorted_list(kv_list, compare_ints) - call assert(allocated(kv_list), "sorted kv_list not allocated") - call assert(size(kv_list) == 4, "sorted kv_list has bad size") - do i = 1, size(kv_list) + call assert(size(kv_list) == n_uniq, "sorted kv_list has bad size") + do i = 1, n_uniq call h%get(kv_list(i)%key, val, success) call assert(success, "key in sorted list was not in hash") call assert(val == kv_list(i)%value, "bad value in sorted list") @@ -75,6 +73,7 @@ subroutine test_get_ptr() call assert(h%key_count() == 2, 'expected two keys in h') enddo + allocate(kv_list(h%key_count())) call h%as_sorted_list(kv_list, compare_ints) call assert(size(kv_list) == 2, "expected size(kv_list) == 2") call assert(kv_list%key == [2, 7], "keys should be [2, 7]") From 6a792c829ea344bf176eeaf963fdd3782b3bbf0b Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 12 Nov 2021 09:20:03 +0100 Subject: [PATCH 68/74] added "get" to benchmark --- Makefile | 2 +- benchmark.cc | 25 +++++++++++++++++++------ benchmark.f90 | 23 ++++++++++++++++------- 3 files changed, 36 insertions(+), 14 deletions(-) diff --git a/Makefile b/Makefile index 1222bf8..c19593a 100644 --- a/Makefile +++ b/Makefile @@ -39,7 +39,7 @@ test: fhash_modules fhash_test.f90 benchmark: fhash_benchmark.out stl_benchmark.out ./fhash_benchmark.out && ./stl_benchmark.out -fhash_benchmark.out: fhash_modules.f90 benchmark.f90 +fhash_benchmark.out: fhash.f90 fhash_modules.f90 benchmark.f90 $(FC) $(FFLAGS_BASIC) $(FFLAGS_RELEASE) fhash_modules.f90 benchmark.f90 -o fhash_benchmark.out stl_benchmark.out: benchmark.cc diff --git a/benchmark.cc b/benchmark.cc index 5677b33..9413498 100644 --- a/benchmark.cc +++ b/benchmark.cc @@ -4,7 +4,7 @@ #include constexpr int N_INTS = 2; -constexpr int N_KEYS = 10000000; +constexpr int N_KEYS = 1e7; int main() { std::cout << "Start C++ STL benchmark:\n"; @@ -12,8 +12,9 @@ int main() { typedef std::array KeyType; std::unordered_map, double, boost::hash> h; - const double t0 = std::clock(); h.reserve(N_KEYS * 2); + const double t0 = std::clock(); + KeyType key; for (int i = 1; i <= N_KEYS; i++) { for (int j = 1; j <= N_INTS; j++) { @@ -21,13 +22,25 @@ int main() { } h[key] = i * 0.5; } - const double t1 = std::clock(); - h.clear(); + double val; + for (int i = 1; i <= N_KEYS; i++) { + for (int j = 1; j <= N_INTS; j++) { + key[j - 1] = i + j; + } + val = h[key]; + } const double t2 = std::clock(); - std::cout << "Time to assemble: " << (t1 - t0) / CLOCKS_PER_SEC << "\n"; - std::cout << "Time to clear: " << (t2 - t1) / CLOCKS_PER_SEC << "\n"; + + h.clear(); + const double t3 = std::clock(); + + std::cout << "Time to assemble / get / clear:" + << " " << (t1 - t0) / CLOCKS_PER_SEC + << " " << (t2 - t1) / CLOCKS_PER_SEC + << " " << (t3 - t2) / CLOCKS_PER_SEC + << "\n"; return 0; } diff --git a/benchmark.f90 b/benchmark.f90 index 197a7ed..169702e 100644 --- a/benchmark.f90 +++ b/benchmark.f90 @@ -9,38 +9,47 @@ program test_benchmark implicit none - call benchmark(n_ints=KEY_ARRAY_SIZE, n_keys=10000000) + call benchmark(n_ints=KEY_ARRAY_SIZE, n_keys=10**7) contains subroutine benchmark(n_ints, n_keys) use int2real_mod + use iso_fortran_env, only: real64 integer, intent(in) :: n_ints, n_keys type(int2real_t) :: h integer :: key(n_ints) integer :: i, j - real :: t0, t1, t2 + real :: t0, t1, t2, t3 + real(real64), pointer :: val write(*,'(a)') "Start fhash benchmark:" write(*,'("n_ints: ", I0, ", n_keys: ", I0)') n_ints, n_keys - call cpu_time(t0) call h%reserve(n_keys * 2) + call cpu_time(t0) + do i = 1, n_keys do j = 1, n_ints key(j) = i + j enddo call h%set(key, i * 0.5d0) enddo - call cpu_time(t1) - call h%clear() + do i = 1, n_keys + do j = 1, n_ints + key(j) = i + j + enddo + val => h%get_ptr(key) ! , autoval=3.0_real64) + enddo call cpu_time(t2) - write(*,'(a,g0.3)') "Time to assemble: ", t1 - t0 - write(*,'(a,g0.3)') "Time to clear: ", t2 - t1 + call h%clear() + call cpu_time(t3) + + write(*,'(a,3(g15.3))') "Time to assemble/ get / clear: ", t1 - t0, t2 - t1, t3 - t2 end subroutine end program From 085aef623f1c87b8cfb9a39f861631210aae7f58 Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Sun, 14 Nov 2021 09:54:23 +0100 Subject: [PATCH 69/74] sort without putting arrays on the stack (also makes permutation faster) --- fhash.f90 | 54 +++++++++++++++++++++++++++++++++++++++++++------- fhash_test.f90 | 34 +++++++++++++++++++++++++++++++ 2 files changed, 81 insertions(+), 7 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index aa11486..0b8a7d8 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -519,12 +519,51 @@ subroutine FHASH_SORT_KV_NAME(kv_list, compare) global_compare_ptr => compare global_sorted_kv_list_ptr => kv_list - kv_list = kv_list(sorting_perm()) - + call permute(kv_list, sorting_perm()) + global_compare_ptr => null() global_sorted_kv_list_ptr => null() end subroutine + subroutine permute(x, perm) + ! Performs + ! x = x(perm) + ! but (i) this is more efficient, and (ii) ifort appears to put `x(perm)` on + ! the stack before copying, causing a segfault for large arrays. + use, intrinsic :: iso_c_binding, only: c_int + use, intrinsic :: iso_fortran_env, only: int8, int16 + + type(FHASH_TYPE_KV_TYPE_NAME), intent(inout) :: x(:) + integer(c_int), intent(in) :: perm(:) + + type(FHASH_TYPE_KV_TYPE_NAME) :: temp + integer :: i, n, j, jnew + integer, parameter :: smallest_int = merge(int8, int16, int8 > 0) + logical(smallest_int), allocatable :: done(:) + + call assert(size(x) == size(perm), "INTERNAL ERROR: permute: inconsistent sizes") + n = size(x) + + allocate(done(n)) + done = .false._smallest_int + do i = 1, n + ! Follow the permutations, which form a cycle: + j = i + temp = x(i) + do + if (done(j)) exit + jnew = perm(j) + if (jnew == i) then + x(j) = temp + else + x(j) = x(jnew) + endif + done(j) = .true._smallest_int + j = jnew + enddo + enddo + end subroutine + impure elemental subroutine deepcopy_fhash(lhs, rhs) class(FHASH_TYPE_NAME), intent(out) :: lhs type(FHASH_TYPE_NAME), intent(in) :: rhs @@ -727,13 +766,12 @@ impure elemental subroutine assert(condition, msg) global_sorted_kv_list_ptr(f_b)%key), kind=c_int) end function - function sorting_perm() result(f_perm) + function sorting_perm() result(perm) use, intrinsic :: iso_c_binding - integer, allocatable :: f_perm(:) + integer(c_int), allocatable, target :: perm(:) integer(c_int) :: i, n - integer(c_int), allocatable, target :: perm(:) type(c_funptr) :: fun interface subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") @@ -752,10 +790,12 @@ subroutine c_qsort(array, elem_count, elem_size, compare) bind(C, name="qsort") "internal error: global sorting state has not been set yet") n = size(global_sorted_kv_list_ptr, kind=c_int) - perm = [(i, i = 1_c_int, n)] + allocate(perm(n)) + do i = 1, n + perm(i) = i + enddo fun = c_funloc(__COMPARE_AT_IDX) if (n > 0_c_int) call c_qsort(c_loc(perm(1)), int(n, kind=c_size_t), c_sizeof(perm(1)), fun) - f_perm = int(perm) end function end module diff --git a/fhash_test.f90 b/fhash_test.f90 index 135dce3..afcba1f 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -41,6 +41,39 @@ subroutine test_as_list call assert(kv_list(2:)%key - kv_list(:size(kv_list)-1)%key > 0, "sorted list should be strictly increasing") end subroutine + subroutine test_large_sort() + ! Test with an array that's too big for the stack. + use i2char_mod + + real, parameter :: gigabytes = 0.001 ! make larger for expensive test + type(i2char_kv_t), allocatable :: kv_list(:) + integer, parameter :: max = 1000 + integer :: i, n, val + real :: x + + n = nint(gigabytes * 1024**3 / (storage_size(kv_list) / 8)) + + ! This list contains duplicate keys, which is not possible for lists + ! obtained from a hash, but it should work anyway: + allocate(kv_list(n)) + do i = 1, n + call random_number(x) + val = nint(x * max) + kv_list(i)%key = val + write(kv_list(i)%value, "(i0)") val + enddo + + call sort_i2char(kv_list, compare_ints) + + do i = 2, n + call assert(kv_list(i-1)%key <= kv_list(i)%key, "large sort: list should be increasing") + enddo + do i = 2, n + read(kv_list(i)%value, *) val + call assert(val == kv_list(i)%key, "large sort: bad value") + enddo + end subroutine + subroutine test_get_ptr() use i2char_mod @@ -202,6 +235,7 @@ program fhash_test call test_insert_get_and_remove_int_ints_ptr() call test_iterate() call test_as_list() + call test_large_sort() call test_deep_storage_size() call test_assignment() From c2921e2167b17aa3e505421ef8f70e9c4f8b55de Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Fri, 19 Nov 2021 09:11:49 +0100 Subject: [PATCH 70/74] simplify node_remove --- fhash.f90 | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 0b8a7d8..8c549fe 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -93,15 +93,6 @@ module FHASH_MODULE_NAME type(node_type), pointer :: next => null() contains - ! If kv is not allocated, fail and return - ! If key is present and node is first in bucket, set first node in bucket to - ! the next node of first. Return success - ! If key is present and the node is another member of the linked list, link the - ! previous node's next node to this node's next node, deallocate this node, - ! return success - ! Otherwise, fail and return 0 - procedure, non_overridable :: node_remove - ! Return the length of the linked list start from the current node. procedure, non_overridable :: node_depth @@ -446,7 +437,7 @@ subroutine remove(this, key, success) if (.not. allocated(first%kv)) then locSuccess = .false. elseif (.not. keys_equal(first%kv%key, key)) then - call node_remove(first%next, key, locSuccess, first) + call node_remove(first, key, locSuccess) elseif (associated(first%next)) then first%kv%key = first%next%kv%key first%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value @@ -463,23 +454,33 @@ subroutine remove(this, key, success) if (present(success)) success = locSuccess end subroutine - recursive subroutine node_remove(this, key, success, last) - class(node_type), intent(inout) :: this, last + recursive subroutine node_remove(last, key, success) + ! If kv is not allocated, fail and return + ! If key is present and node is first in bucket, set first node in bucket to + ! the next node of first. Return success + ! If key is present and the node is another member of the linked list, link the + ! previous node's next node to this node's next node, deallocate this node, + ! return success + ! Otherwise, fail and return 0 + type(node_type), intent(inout) :: last KEY_TYPE, intent(in) :: key logical, intent(out) :: success - if (.not. allocated(this%kv)) then - ! Not found. (Initial node in the bucket not set) + type(node_type), pointer :: next + + next => last%next + + if (.not. allocated(next%kv)) then success = .false. - else if (keys_equal(this%kv%key, key)) then - last%next => this%next - nullify(this%next) - deallocate(this%kv) + else if (keys_equal(next%kv%key, key)) then + last%next => next%next + nullify(next%next) + deallocate(next%kv) success = .true. - else if (associated(this%next)) then - call this%next%node_remove(key, success, this) - else + else if (.not. associated(next%next)) then success = .false. + else + call node_remove(next, key, success) endif end subroutine From dcedd514567c3d1c80a782c6ed9292dd1a4d9b4d Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Wed, 24 Nov 2021 20:10:28 +0100 Subject: [PATCH 71/74] simplify node_get so ifort can do tail call resursion (gfortran already did) --- fhash.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index 8c549fe..e366b86 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -332,10 +332,10 @@ recursive subroutine node_get(this, key, value, success) else if (keys_equal(this%kv%key, key)) then value VALUE_ASSIGNMENT this%kv%value if (present(success)) success = .true. - else if (associated(this%next)) then + elseif (.not. associated(this%next)) then + if (present(success)) success = .false. + else call node_get(this%next, key, value, success) - elseif (present(success)) then - success = .false. endif end subroutine From 7195039f4265b57b2440108cd89e23cd1d8a24df Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 22 Nov 2021 17:57:31 +0100 Subject: [PATCH 72/74] FIX memory leak in "remove" (had been there since before the repo fork) --- fhash.f90 | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/fhash.f90 b/fhash.f90 index e366b86..be1b1c0 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -429,27 +429,28 @@ subroutine remove(this, key, success) integer :: bucket_id logical :: locSuccess + type(node_type), pointer :: first, temp call assert(associated(this%buckets), "remove: fhash has not been initialized") bucket_id = this%key2bucket(key) - associate(first => this%buckets(bucket_id)) - if (.not. allocated(first%kv)) then - locSuccess = .false. - elseif (.not. keys_equal(first%kv%key, key)) then - call node_remove(first, key, locSuccess) - elseif (associated(first%next)) then - first%kv%key = first%next%kv%key - first%kv%value VALUE_ASSIGNMENT this%buckets(bucket_id)%next%kv%value - deallocate(first%next%kv) - first%next => first%next%next - locSuccess = .true. - else - deallocate(first%kv) - locSuccess = .true. - endif - end associate - + first => this%buckets(bucket_id) + + if (.not. allocated(first%kv)) then + locSuccess = .false. + elseif (.not. keys_equal(first%kv%key, key)) then + call node_remove(first, key, locSuccess) + elseif (associated(first%next)) then + call move_alloc(first%next%kv, first%kv) + temp => first%next + first%next => first%next%next + deallocate(temp) + locSuccess = .true. + else + deallocate(first%kv) + locSuccess = .true. + endif + if (locSuccess) this%n_keys = this%n_keys - 1 if (present(success)) success = locSuccess end subroutine From ad027017658fed8c9244bcb42471c6c2fb3d134e Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Mon, 22 Nov 2021 21:43:53 +0100 Subject: [PATCH 73/74] FIX memory leak in test_insert_get_and_remove_int_ints_ptr --- fhash_test.f90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/fhash_test.f90 b/fhash_test.f90 index afcba1f..8e97814 100644 --- a/fhash_test.f90 +++ b/fhash_test.f90 @@ -311,7 +311,8 @@ subroutine test_insert_and_get_int_ints_ptr() subroutine test_insert_get_and_remove_int_ints_ptr() type(int_ints_ptr_t) :: h integer, parameter :: num_values = 50 - type(ints_type), pointer :: pValues(:), pValue + type(ints_type), pointer :: pValue + type(ints_type), target, allocatable :: pValues(:) logical :: success integer :: i, key, status type(int_ints_ptr_iter_t) :: it @@ -324,9 +325,9 @@ subroutine test_insert_get_and_remove_int_ints_ptr() ! add do i = 1, num_values + allocate(pValues(i)%ints(2)) + pValues(i)%ints(1) = i pValue => pValues(i) - allocate(pValue%ints(2)) - pValue%ints(1) = i call h%set(i, pValue) end do @@ -334,7 +335,6 @@ subroutine test_insert_get_and_remove_int_ints_ptr() ! get do i = num_values, i, -1 - nullify(pValue) call h%get(i, pValue, success) if (.not. success) stop 'expect a value for given key ' if (pValue%ints(1) .ne. pValues(i)%ints(1)) stop 'expect different value for given key' @@ -384,8 +384,6 @@ subroutine test_insert_get_and_remove_int_ints_ptr() #endif call h%clear() - - deallocate(pValues) end subroutine subroutine test_iterate() From f851a72b076feaa231b90b147e2cbc8ed1da252a Mon Sep 17 00:00:00 2001 From: Aldo Hennink Date: Thu, 25 Nov 2021 08:53:57 +0100 Subject: [PATCH 74/74] deleted redundant nullify --- fhash.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/fhash.f90 b/fhash.f90 index be1b1c0..fe80937 100644 --- a/fhash.f90 +++ b/fhash.f90 @@ -475,7 +475,6 @@ recursive subroutine node_remove(last, key, success) success = .false. else if (keys_equal(next%kv%key, key)) then last%next => next%next - nullify(next%next) deallocate(next%kv) success = .true. else if (.not. associated(next%next)) then