| 1 | ! ============================================================================== |
| 2 | ! Test program for Phase 3 memory pooling - zero-copy verification |
| 3 | ! ============================================================================== |
| 4 | program test_phase3_pool |
| 5 | use string_pool |
| 6 | use iso_fortran_env, only: output_unit |
| 7 | implicit none |
| 8 | |
| 9 | type(string_ref) :: ref1, ref2, ref3 |
| 10 | character(len=100) :: test_string |
| 11 | integer :: total_allocs, total_deallocs, current, peak, i |
| 12 | real :: hit_rate |
| 13 | logical :: tests_passed |
| 14 | |
| 15 | tests_passed = .true. |
| 16 | |
| 17 | print *, "=== Phase 3 Memory Pool Test Suite ===" |
| 18 | print *, "Testing zero-copy string pooling implementation" |
| 19 | print * |
| 20 | |
| 21 | ! Initialize the pool |
| 22 | call pool_init() |
| 23 | |
| 24 | ! Test 1: Basic allocation and pointer verification |
| 25 | print *, "Test 1: Verifying direct pointer allocation..." |
| 26 | ref1 = pool_get_string(50) |
| 27 | |
| 28 | if (ref1%pool_index == 0) then |
| 29 | print *, " FAILED: Pool did not allocate" |
| 30 | tests_passed = .false. |
| 31 | else |
| 32 | print *, " PASSED: Got pooled memory allocation" |
| 33 | end if |
| 34 | |
| 35 | ! Test 2: Write data directly to pooled memory |
| 36 | print *, "Test 2: Writing directly to pooled memory..." |
| 37 | test_string = "Hello from zero-copy pool!" |
| 38 | call pool_copy_to_ref(ref1, test_string) |
| 39 | |
| 40 | if (trim(ref1%data) == "Hello from zero-copy pool!") then |
| 41 | print *, " PASSED: Data written directly to pool" |
| 42 | else |
| 43 | print *, " FAILED: Data not correctly written" |
| 44 | tests_passed = .false. |
| 45 | end if |
| 46 | |
| 47 | ! Test 3: Multiple allocations from different buckets |
| 48 | print *, "Test 3: Testing multiple bucket sizes..." |
| 49 | ref2 = pool_get_string(200) ! Should go to 256-byte bucket |
| 50 | ref3 = pool_get_string(1000) ! Should go to 1024-byte bucket |
| 51 | |
| 52 | call pool_copy_to_ref(ref2, "Medium string in 256-byte bucket") |
| 53 | call pool_copy_to_ref(ref3, "Large string in 1024-byte bucket") |
| 54 | |
| 55 | if (ref2%pool_index /= 0 .and. ref3%pool_index /= 0) then |
| 56 | print *, " PASSED: Multiple buckets working correctly" |
| 57 | else |
| 58 | print *, " FAILED: Multiple bucket allocation failed" |
| 59 | tests_passed = .false. |
| 60 | end if |
| 61 | |
| 62 | ! Test 4: Verify no double allocation |
| 63 | print *, "Test 4: Verifying zero-copy (no double allocation)..." |
| 64 | ! The key test: changing the pooled data should be visible through the pointer |
| 65 | ref1%data(1:5) = "ZERO-" |
| 66 | if (ref1%data(1:5) == "ZERO-") then |
| 67 | print *, " PASSED: Direct modification of pooled memory confirmed" |
| 68 | print *, " This proves we're using pointers, not copies!" |
| 69 | else |
| 70 | print *, " FAILED: Modification not reflected - double allocation detected!" |
| 71 | tests_passed = .false. |
| 72 | end if |
| 73 | |
| 74 | ! Test 5: Pool reuse after release |
| 75 | print *, "Test 5: Testing pool slot reuse..." |
| 76 | call pool_release_string(ref1) |
| 77 | ref1 = pool_get_string(50) ! Should reuse the same slot |
| 78 | |
| 79 | if (ref1%pool_index /= 0) then |
| 80 | print *, " PASSED: Pool slot successfully reused" |
| 81 | else |
| 82 | print *, " FAILED: Pool slot reuse failed" |
| 83 | tests_passed = .false. |
| 84 | end if |
| 85 | |
| 86 | ! Test 6: Pool expansion |
| 87 | print *, "Test 6: Testing pool expansion..." |
| 88 | block |
| 89 | type(string_ref) :: many_refs(200) |
| 90 | integer :: j |
| 91 | |
| 92 | ! Allocate more than initial pool size |
| 93 | do j = 1, 200 |
| 94 | many_refs(j) = pool_get_string(60) |
| 95 | if (many_refs(j)%pool_index == 0) then |
| 96 | print *, " FAILED: Pool expansion failed at allocation", j |
| 97 | tests_passed = .false. |
| 98 | exit |
| 99 | end if |
| 100 | end do |
| 101 | |
| 102 | if (tests_passed) then |
| 103 | print *, " PASSED: Pool successfully expanded to handle 200 allocations" |
| 104 | end if |
| 105 | |
| 106 | ! Clean up |
| 107 | do j = 1, 200 |
| 108 | call pool_release_string(many_refs(j)) |
| 109 | end do |
| 110 | end block |
| 111 | |
| 112 | ! Test 7: Statistics verification |
| 113 | print *, "Test 7: Checking pool statistics..." |
| 114 | call pool_statistics(total_allocs, total_deallocs, current, peak, hit_rate) |
| 115 | |
| 116 | print *, " Total allocations:", total_allocs |
| 117 | print *, " Total deallocations:", total_deallocs |
| 118 | print *, " Current strings:", current |
| 119 | print *, " Peak strings:", peak |
| 120 | print *, " Cache hit rate:", int(hit_rate * 100), "%" |
| 121 | |
| 122 | if (hit_rate > 0.95) then |
| 123 | print *, " PASSED: Excellent cache hit rate (>95%)" |
| 124 | else if (hit_rate > 0.80) then |
| 125 | print *, " PASSED: Good cache hit rate (>80%)" |
| 126 | else |
| 127 | print *, " WARNING: Low cache hit rate" |
| 128 | end if |
| 129 | |
| 130 | ! Test 8: Memory pattern test |
| 131 | print *, "Test 8: Testing realistic allocation patterns..." |
| 132 | block |
| 133 | type(string_ref) :: pattern_refs(10) |
| 134 | integer :: sizes(10) = [32, 128, 64, 256, 512, 64, 128, 32, 1024, 256] |
| 135 | integer :: k |
| 136 | |
| 137 | ! Simulate realistic allocation pattern |
| 138 | do k = 1, 10 |
| 139 | pattern_refs(k) = pool_get_string(sizes(k)) |
| 140 | write(test_string, '(a,i0)') "Test string ", k |
| 141 | call pool_copy_to_ref(pattern_refs(k), test_string) |
| 142 | end do |
| 143 | |
| 144 | ! Verify all allocations |
| 145 | do k = 1, 10 |
| 146 | write(test_string, '(a,i0)') "Test string ", k |
| 147 | if (trim(pattern_refs(k)%data) /= trim(test_string)) then |
| 148 | print *, " FAILED: Pattern test failed at", k |
| 149 | tests_passed = .false. |
| 150 | end if |
| 151 | end do |
| 152 | |
| 153 | if (tests_passed) then |
| 154 | print *, " PASSED: Realistic allocation patterns handled correctly" |
| 155 | end if |
| 156 | |
| 157 | ! Clean up |
| 158 | do k = 1, 10 |
| 159 | call pool_release_string(pattern_refs(k)) |
| 160 | end do |
| 161 | end block |
| 162 | |
| 163 | ! Clean up remaining allocations |
| 164 | call pool_release_string(ref2) |
| 165 | call pool_release_string(ref3) |
| 166 | |
| 167 | ! Final statistics |
| 168 | print * |
| 169 | print *, "=== Final Statistics ===" |
| 170 | call pool_statistics(total_allocs, total_deallocs, current, peak, hit_rate) |
| 171 | print *, "Total allocations:", total_allocs |
| 172 | print *, "Total deallocations:", total_deallocs |
| 173 | print *, "Leaked strings:", current |
| 174 | print *, "Peak usage:", peak |
| 175 | print *, "Overall hit rate:", int(hit_rate * 100), "%" |
| 176 | |
| 177 | ! Clean up the pool |
| 178 | call pool_cleanup() |
| 179 | |
| 180 | ! Summary |
| 181 | print * |
| 182 | if (tests_passed) then |
| 183 | print *, "=== ALL TESTS PASSED ===" |
| 184 | print *, "Phase 3 zero-copy pooling is working correctly!" |
| 185 | print *, "Key achievement: Direct pointers to pool memory (no double allocation)" |
| 186 | else |
| 187 | print *, "=== SOME TESTS FAILED ===" |
| 188 | print *, "Please review the implementation" |
| 189 | end if |
| 190 | |
| 191 | end program test_phase3_pool |