fortsh Public

Watch 0 Fork 0 Star 0
Fortran · 11084 bytes Raw Blame History
1 ! ==============================================================================
2 ! Module: memory_profiler
3 ! Purpose: Track memory allocations and detect leaks
4 !
5 ! Provides instrumentation similar to valgrind/AddressSanitizer
6 ! ==============================================================================
7 module memory_profiler
8 use iso_fortran_env, only: int64, real64, error_unit
9 implicit none
10 private
11
12 public :: mem_track_alloc, mem_track_dealloc, mem_report
13 public :: mem_check_leaks, mem_enable_tracking, mem_disable_tracking
14 public :: mem_get_current_usage, mem_get_peak_usage
15
16 ! Tracking record for each allocation
17 type :: alloc_record
18 integer(int64) :: address = 0
19 integer(int64) :: size = 0
20 character(len=256) :: location = ''
21 character(len=64) :: type_name = ''
22 integer :: line_number = 0
23 logical :: active = .false.
24 integer(int64) :: alloc_time = 0
25 end type alloc_record
26
27 ! Site statistics for reporting
28 type :: site_stats
29 character(len=256) :: location = ''
30 integer :: count = 0
31 integer(int64) :: total_size = 0
32 end type site_stats
33
34 ! Module state
35 integer, parameter :: MAX_TRACKED = 10000
36 type(alloc_record) :: allocations(MAX_TRACKED)
37 integer :: num_allocations = 0
38 integer :: num_deallocations = 0
39 integer :: num_active = 0
40 integer(int64) :: current_usage = 0
41 integer(int64) :: peak_usage = 0
42 logical :: tracking_enabled = .false.
43 integer(int64) :: start_time = 0
44
45 ! Leak detection thresholds
46 integer, parameter :: LEAK_WARNING_SIZE = 1048576 ! 1MB
47 integer, parameter :: LEAK_ERROR_SIZE = 10485760 ! 10MB
48
49 contains
50
51 ! Enable memory tracking
52 subroutine mem_enable_tracking()
53 tracking_enabled = .true.
54 call system_clock(start_time)
55 write(error_unit, '(a)') '=== Memory profiling ENABLED ==='
56 end subroutine mem_enable_tracking
57
58 ! Disable memory tracking
59 subroutine mem_disable_tracking()
60 tracking_enabled = .false.
61 write(error_unit, '(a)') '=== Memory profiling DISABLED ==='
62 end subroutine mem_disable_tracking
63
64 ! Track an allocation
65 subroutine mem_track_alloc(ptr_address, size, location, type_name, line_num)
66 integer(int64), intent(in) :: ptr_address
67 integer(int64), intent(in) :: size
68 character(len=*), intent(in) :: location
69 character(len=*), intent(in) :: type_name
70 integer, intent(in) :: line_num
71 integer :: i, slot
72 integer(int64) :: current_time
73
74 if (.not. tracking_enabled) return
75
76 ! Find empty slot
77 slot = 0
78 do i = 1, MAX_TRACKED
79 if (.not. allocations(i)%active) then
80 slot = i
81 exit
82 end if
83 end do
84
85 if (slot == 0) then
86 write(error_unit, '(a)') 'WARNING: Memory tracker full, cannot track allocation'
87 return
88 end if
89
90 call system_clock(current_time)
91
92 ! Record allocation
93 allocations(slot)%address = ptr_address
94 allocations(slot)%size = size
95 allocations(slot)%location = location
96 allocations(slot)%type_name = type_name
97 allocations(slot)%line_number = line_num
98 allocations(slot)%active = .true.
99 allocations(slot)%alloc_time = current_time
100
101 ! Update statistics
102 num_allocations = num_allocations + 1
103 num_active = num_active + 1
104 current_usage = current_usage + size
105 if (current_usage > peak_usage) peak_usage = current_usage
106
107 ! Warn on large allocations
108 if (size > LEAK_WARNING_SIZE) then
109 write(error_unit, '(a,i0,a,a,a,i0)') &
110 'LARGE ALLOCATION: ', size, ' bytes at ', trim(location), ':', line_num
111 end if
112
113 end subroutine mem_track_alloc
114
115 ! Track a deallocation
116 subroutine mem_track_dealloc(ptr_address, location, line_num)
117 integer(int64), intent(in) :: ptr_address
118 character(len=*), intent(in) :: location
119 integer, intent(in) :: line_num
120 integer :: i
121 logical :: found
122
123 if (.not. tracking_enabled) return
124
125 found = .false.
126 do i = 1, MAX_TRACKED
127 if (allocations(i)%active .and. allocations(i)%address == ptr_address) then
128 found = .true.
129 current_usage = current_usage - allocations(i)%size
130 allocations(i)%active = .false.
131 num_deallocations = num_deallocations + 1
132 num_active = num_active - 1
133 exit
134 end if
135 end do
136
137 if (.not. found) then
138 write(error_unit, '(a,z16,a,a,a,i0)') &
139 'WARNING: Deallocating untracked pointer 0x', ptr_address, &
140 ' at ', trim(location), ':', line_num
141 end if
142
143 end subroutine mem_track_dealloc
144
145 ! Check for memory leaks
146 subroutine mem_check_leaks()
147 integer :: i, leak_count
148 integer(int64) :: leaked_bytes
149 character(len=512) :: leak_msg
150
151 if (.not. tracking_enabled) return
152
153 leak_count = 0
154 leaked_bytes = 0
155
156 write(error_unit, '(a)') ''
157 write(error_unit, '(a)') '=== MEMORY LEAK CHECK ==='
158
159 do i = 1, MAX_TRACKED
160 if (allocations(i)%active) then
161 leak_count = leak_count + 1
162 leaked_bytes = leaked_bytes + allocations(i)%size
163
164 write(leak_msg, '(a,i0,a,a,a,i0,a,a)') &
165 'LEAK: ', allocations(i)%size, ' bytes from ', &
166 trim(allocations(i)%location), ':', allocations(i)%line_number, &
167 ' (', trim(allocations(i)%type_name), ')'
168 write(error_unit, '(a)') trim(leak_msg)
169 end if
170 end do
171
172 if (leak_count > 0) then
173 write(error_unit, '(a,i0,a,i0,a)') &
174 'TOTAL: ', leak_count, ' leaks, ', leaked_bytes, ' bytes leaked'
175 if (leaked_bytes > LEAK_ERROR_SIZE) then
176 write(error_unit, '(a)') 'ERROR: Severe memory leak detected!'
177 end if
178 else
179 write(error_unit, '(a)') 'No memory leaks detected'
180 end if
181
182 write(error_unit, '(a)') '========================='
183 write(error_unit, '()')
184
185 end subroutine mem_check_leaks
186
187 ! Generate memory report
188 subroutine mem_report()
189 integer :: i, bucket_counts(10), bucket_sizes(10)
190 integer(int64) :: total_time
191 real(real64) :: elapsed_seconds
192
193 if (.not. tracking_enabled) return
194
195 call system_clock(total_time)
196 elapsed_seconds = real(total_time - start_time) / 1000.0
197
198 write(error_unit, '(a)') ''
199 write(error_unit, '(a)') '=== MEMORY USAGE REPORT ==='
200 write(error_unit, '(a,f8.2,a)') 'Profiling duration: ', elapsed_seconds, ' seconds'
201 write(error_unit, '(a,i0)') 'Total allocations: ', num_allocations
202 write(error_unit, '(a,i0)') 'Total deallocations: ', num_deallocations
203 write(error_unit, '(a,i0)') 'Currently active: ', num_active
204 write(error_unit, '(a,i0,a)') 'Current usage: ', current_usage, ' bytes'
205 write(error_unit, '(a,i0,a)') 'Peak usage: ', peak_usage, ' bytes'
206
207 ! Size distribution
208 bucket_counts = 0
209 bucket_sizes = [16, 64, 256, 1024, 4096, 16384, 65536, 262144, 1048576, huge(1)]
210
211 do i = 1, MAX_TRACKED
212 if (allocations(i)%active) then
213 if (allocations(i)%size <= bucket_sizes(1)) then
214 bucket_counts(1) = bucket_counts(1) + 1
215 else if (allocations(i)%size <= bucket_sizes(2)) then
216 bucket_counts(2) = bucket_counts(2) + 1
217 else if (allocations(i)%size <= bucket_sizes(3)) then
218 bucket_counts(3) = bucket_counts(3) + 1
219 else if (allocations(i)%size <= bucket_sizes(4)) then
220 bucket_counts(4) = bucket_counts(4) + 1
221 else if (allocations(i)%size <= bucket_sizes(5)) then
222 bucket_counts(5) = bucket_counts(5) + 1
223 else if (allocations(i)%size <= bucket_sizes(6)) then
224 bucket_counts(6) = bucket_counts(6) + 1
225 else if (allocations(i)%size <= bucket_sizes(7)) then
226 bucket_counts(7) = bucket_counts(7) + 1
227 else if (allocations(i)%size <= bucket_sizes(8)) then
228 bucket_counts(8) = bucket_counts(8) + 1
229 else if (allocations(i)%size <= bucket_sizes(9)) then
230 bucket_counts(9) = bucket_counts(9) + 1
231 else
232 bucket_counts(10) = bucket_counts(10) + 1
233 end if
234 end if
235 end do
236
237 write(error_unit, '(a)') ''
238 write(error_unit, '(a)') 'Size distribution of active allocations:'
239 write(error_unit, '(a,i0)') ' 0-16 bytes: ', bucket_counts(1)
240 write(error_unit, '(a,i0)') ' 17-64 bytes: ', bucket_counts(2)
241 write(error_unit, '(a,i0)') ' 65-256 bytes: ', bucket_counts(3)
242 write(error_unit, '(a,i0)') ' 257-1K bytes: ', bucket_counts(4)
243 write(error_unit, '(a,i0)') ' 1-4K bytes: ', bucket_counts(5)
244 write(error_unit, '(a,i0)') ' 4-16K bytes: ', bucket_counts(6)
245 write(error_unit, '(a,i0)') ' 16-64K bytes: ', bucket_counts(7)
246 write(error_unit, '(a,i0)') ' 64-256K bytes: ', bucket_counts(8)
247 write(error_unit, '(a,i0)') ' 256K-1M bytes: ', bucket_counts(9)
248 write(error_unit, '(a,i0)') ' >1M bytes: ', bucket_counts(10)
249
250 ! Top allocation sites
251 call report_top_allocators()
252
253 write(error_unit, '(a)') '========================='
254 write(error_unit, '()')
255
256 end subroutine mem_report
257
258 ! Report top allocation sites
259 subroutine report_top_allocators()
260 type(site_stats) :: sites(100)
261 integer :: num_sites, i, j
262 logical :: found
263
264 num_sites = 0
265 sites%count = 0
266 sites%total_size = 0
267
268 ! Aggregate by location
269 do i = 1, MAX_TRACKED
270 if (allocations(i)%active) then
271 found = .false.
272 do j = 1, num_sites
273 if (sites(j)%location == allocations(i)%location) then
274 sites(j)%count = sites(j)%count + 1
275 sites(j)%total_size = sites(j)%total_size + allocations(i)%size
276 found = .true.
277 exit
278 end if
279 end do
280
281 if (.not. found .and. num_sites < 100) then
282 num_sites = num_sites + 1
283 sites(num_sites)%location = allocations(i)%location
284 sites(num_sites)%count = 1
285 sites(num_sites)%total_size = allocations(i)%size
286 end if
287 end if
288 end do
289
290 ! Sort and display top sites
291 if (num_sites > 0) then
292 write(error_unit, '(a)') ''
293 write(error_unit, '(a)') 'Top allocation sites:'
294 call sort_sites_by_size(sites, num_sites)
295 do i = 1, min(5, num_sites)
296 write(error_unit, '(2x,a,a,i0,a,i0,a)') &
297 trim(sites(i)%location), ': ', &
298 sites(i)%count, ' allocations, ', &
299 sites(i)%total_size, ' bytes'
300 end do
301 end if
302
303 end subroutine report_top_allocators
304
305 ! Sort allocation sites by total size
306 subroutine sort_sites_by_size(sites, n)
307 type(site_stats), intent(inout) :: sites(:)
308 integer, intent(in) :: n
309 type(site_stats) :: temp
310 integer :: i, j
311
312 do i = 1, n-1
313 do j = i+1, n
314 if (sites(j)%total_size > sites(i)%total_size) then
315 temp = sites(i)
316 sites(i) = sites(j)
317 sites(j) = temp
318 end if
319 end do
320 end do
321
322 end subroutine sort_sites_by_size
323
324 ! Get current memory usage
325 function mem_get_current_usage() result(usage)
326 integer(int64) :: usage
327 usage = current_usage
328 end function mem_get_current_usage
329
330 ! Get peak memory usage
331 function mem_get_peak_usage() result(usage)
332 integer(int64) :: usage
333 usage = peak_usage
334 end function mem_get_peak_usage
335
336 end module memory_profiler