DISPATCH
omp_lock_mod.f90
1 ! $Id: 0fbbfd53090baf40c6cf64fae40daff833bae325 $
2 !===============================================================================
3 !> The lock module uses nested locks, to allow versatile use of locks, where
4 !> a procedure may want to make sure to lock a data type, even though it may
5 !> (or may not) already have been locked by another procedure in the calling
6 !> hierarchy.
7 !>
8 !> NOTE: Enabling trace_mod here, via the TRACE macro, causes a dependency
9 !> loop, and can only be compiled if/when the code is already successfully
10 !> compiled. It should only be used to trace problems with locks.
11 !===============================================================================
13  USE io_unit_mod
14  USE omp_mod
15  USE omp_timer_mod
16  USE omp_lib
17 !define TRACE
18 #ifdef TRACE
19  USE trace_mod
20 #endif
21  implicit none
22  private
23  type, public:: lock_t
24  integer:: id=-1
25  integer(kind=omp_nest_lock_kind):: lock
26  integer:: thread=-1
27  character(len=4):: kind = 'void'
28  integer:: level=0
29  logical:: on
30  !real:: verbose=0.0
31  real(8):: wait_time=0.0_8 ! time waiting for lock
32  real(8):: hold_time=0.0_8 ! time holding lock
33  real(8):: start_time=0.0_8 ! start time
34  real(8):: used_time=0.0_8 ! used time
35  integer(8):: n_hold=0_8 ! number of times holding lock
36  logical:: links=.false. ! lock nbor lists
37  logical:: tasks=.false. ! lock task memory updates
38  type(lock_t), pointer:: next => null()
39  contains
40  procedure:: init
41  procedure:: append
42  procedure:: set
43  procedure:: test
44  procedure:: check
45  procedure:: unset
46  procedure:: destroy
47  procedure, nopass:: info
48  end type
49  integer, save:: verbose=0
50  real, save:: verbose_time=0.0
51  integer, save:: id_save=-1, n_lock=0
52  logical, save:: on = .true.
53  character(len=6):: log='queue'
54  character(len=6):: ext, ext1, ext2
55  integer:: unit
56  real(8):: wait_time=0d0, alternate_time=0d0, alternate_next=0d0
57  type(lock_t), save, public:: omp_lock
58 CONTAINS
59 
60 !===============================================================================
61 !> Initialize a lock, taking care not to do it more than once
62 !===============================================================================
63 SUBROUTINE init (self, kind, id)
64  class(lock_t), target:: self
65  integer, optional:: id
66  character(len=*), optional:: kind
67  character(len=64):: filename
68  logical omp_in_parallel
69  logical, save:: tasks=.true., links=.false.
70  integer:: iostat
71  logical:: set_id
72  logical:: first_time=.true.
73  namelist /lock_params/ on, verbose, verbose_time, log, tasks, links, &
74  alternate_time
75  !-----------------------------------------------------------------------------
76  if (.not.on) return
77 #ifdef TRACE
78  call trace%begin('lock_t%init')
79 #endif
80  !$omp critical (lock_cr)
81  if (self%id == -1) then
82  if (first_time) then
83  rewind(io_unit%input)
84  read (io_unit%input, lock_params, iostat=iostat)
85  write (io_unit%output, lock_params)
86  if (trim(log)=='queue') then
87  unit = io_unit%queue
88  else if (trim(log)=='log') then
89  unit = io_unit%log
90  else
91  unit = io_unit%output
92  end if
93  if (alternate_time > 0d0) then
94  close (unit)
95  ext = '.lock1'
96  ext1 = '.lock1'
97  ext2 = '.lock2'
98  filename = trim(io_unit%rankbase)//ext
99  open (unit, file=trim(filename), form='formatted', &
100  status='unknown')
101  alternate_next = wallclock() + alternate_time
102  end if
103  first_time = .false.
104  end if
105  call omp_init_nest_lock (self%lock)
106  omp_lock%tasks = tasks
107  omp_lock%links = links
108  if (present(id)) then
109  self%id = id
110  id_save = max(id_save,id)
111  set_id = .true.
112  else
113  id_save = id_save+1
114  self%id = id_save
115  set_id = .false.
116  end if
117  if (present(kind)) self%kind = kind(1:4)
118  if (wallclock() < verbose_time .or. verbose > 1) &
119  write(unit,*) omp_get_thread_num(), 'initialized lock kind, id ', &
120  self%kind, self%id, set_id
121  omp_lock%on = on
122  end if
123  !$omp end critical (lock_cr)
124  if (omp%nthreads == 1) &
125  on = .false.
126 #ifdef TRACE
127  call trace%end()
128 #endif
129 END SUBROUTINE init
130 
131 !===============================================================================
132 !> Append a lock to a simple linked list
133 !===============================================================================
134 SUBROUTINE append (self)
135  class(lock_t), target:: self
136  !-----------------------------------------------------------------------------
137  if (.not.on) return
138  !$omp critical (lock_cr)
139  self%next => omp_lock%next
140  omp_lock%next => self
141  n_lock = n_lock+1
142  !$omp end critical (lock_cr)
143 END SUBROUTINE append
144 
145 !===============================================================================
146 !> Return with the lock, waiting if necessary, and creating the lock if needed
147 !===============================================================================
148 SUBROUTINE set (self, label)
149  class(lock_t):: self
150  character(len=*), optional:: label
151  character(len=32):: filename
152  integer:: thread, othread, level
153  real(8):: wc
154  !-----------------------------------------------------------------------------
155  if (.not.on) return
156  if (self%id == -1) call self%init
157 #ifdef TRACE
158  call trace%begin('lock_t%set')
159 #endif
160  thread = omp_get_thread_num()
161  !-----------------------------------------------------------------------------
162  ! Must print log info before the lock, to reveal dead-locks
163  !-----------------------------------------------------------------------------
164  call alternate_log (self)
165  wc = wallclock()
166  if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0) then
167  if (present(label)) then
168  write (unit,'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
169  ' lock kind, id, level, thread = ', self%kind, self%id, &
170  self%level, thread, ' get at '//label
171  else
172  write (unit,'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
173  ' lock kind, id, level, thread = ', self%kind, self%id, &
174  self%level, thread, ' get'
175  end if
176  end if
177  wc = wallclock()
178  self%start_time = wc
179  call omp_set_nest_lock (self%lock)
180  wc = wallclock()
181  self%used_time = wc - self%start_time
182  self%wait_time = self%wait_time + self%used_time
183  self%n_hold = self%n_hold + 1
184  !$omp atomic update
185  wait_time = wait_time + self%used_time
186  self%thread = thread
187  !$omp atomic update
188  self%level = self%level+1
189  !$omp flush
190  if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0) then
191  write (unit,'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
192  ' lock kind, id, level, thread = ', self%kind, self%id, &
193  self%level, thread, ' set'
194  end if
195 #ifdef TRACE
196  call trace%end()
197 #endif
198 END SUBROUTINE set
199 
200 !===============================================================================
201 !> Alternate between two log files
202 !===============================================================================
203 SUBROUTINE alternate_log (self)
204  class(lock_t):: self
205  real(8):: wc
206  !-----------------------------------------------------------------------------
207  if (alternate_time > 0d0) then
208  wc = wallclock()
209  if (wc > alternate_next) then
210  ext = ext2
211  ext2 = ext1
212  ext1 = ext
213  close (unit)
214  open (unit, file=trim(io_unit%rankbase)//ext, form='formatted', &
215  status='unknown')
216  alternate_next = wc + alternate_time
217  end if
218  end if
219 END SUBROUTINE alternate_log
220 
221 !===============================================================================
222 !> Return true if we already have the lock, or if we get it now
223 !===============================================================================
224 FUNCTION test (self) RESULT (out)
225  class(lock_t):: self
226  logical:: out
227  integer:: thread
228  real(8):: wc
229  !-----------------------------------------------------------------------------
230  if (.not.on) return
231 #ifdef TRACE
232  call trace%begin('lock_t%test')
233 #endif
234  thread = omp_get_thread_num()
235  !print *, thread, ' set lock id, thread', self%id, self%thread
236  !$omp flush
237  !print *, thread, ' testing lock id', self%id, self%thread
238  if (thread == self%thread) then
239  out = .true.
240  !print *, thread, ' already has lock id', self%id
241  else
242  !print *, thread, ' omp_test_lock for id', self%id
243  out = omp_test_nest_lock(self%lock)
244  if (out) then
245  self%thread = thread
246  !$omp atomic update
247  self%level = self%level+1
248  wc = wallclock()
249  if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0) then
250  write (io_unit%log,'(f10.6,i4,a,i6,i3,a)') wc, thread, ' lock id', &
251  self%id, self%level, ' test'
252  end if
253  else
254  !print *, thread, ' failed to acquire lock id', self%id, self%thread
255  end if
256  end if
257  !$omp flush
258 #ifdef TRACE
259  call trace%end()
260 #endif
261 END FUNCTION test
262 
263 !===============================================================================
264 !> Return true only if we have rightful access to the locked item
265 !===============================================================================
266 FUNCTION check (self) RESULT (out)
267  class(lock_t):: self
268  logical:: out
269  integer:: thread
270  !-----------------------------------------------------------------------------
271  thread = omp_get_thread_num()
272  out = (thread == self%thread)
273 END FUNCTION check
274 
275 !===============================================================================
276 !> Unset the associated thread number and release the lock (in that order!)
277 !===============================================================================
278 SUBROUTINE unset (self, label)
279  class(lock_t):: self
280  character(len=*), optional:: label
281  integer:: thread, level
282  real(8):: wc
283  !-----------------------------------------------------------------------------
284  if (.not.on) return
285 #ifdef TRACE
286  call trace%begin('lock_t%unset')
287 #endif
288  thread = omp_get_thread_num()
289  !$omp atomic update
290  self%level = self%level-1
291  level = self%level
292  if (self%level==0) then
293  self%thread = -1
294  end if
295  !$omp flush
296  call omp_unset_nest_lock (self%lock)
297  wc = wallclock()
298  self%used_time = wc - self%start_time
299  self%hold_time = self%hold_time + self%used_time
300  !write(unit,*) &
301  ! 'lock%unset: kind, id, thread, level = ', self%kind, self%id, self%thread, self%level
302  call alternate_log (self)
303  if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0) then
304  if (present(label)) then
305  write (unit,'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
306  ' lock kind, id, level, thread = ', self%kind, self%id, level, thread, ' unset at '//label
307  else
308  write (unit,'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
309  ' lock kind, id, level, thread = ', self%kind, self%id, level, thread, ' unset'
310  end if
311  end if
312 #ifdef TRACE
313  call trace%end()
314 #endif
315 END SUBROUTINE unset
316 
317 !===============================================================================
318 SUBROUTINE destroy (self)
319  class(lock_t):: self
320  !-----------------------------------------------------------------------------
321  if (.not.on) return
322  call omp_destroy_nest_lock (self%lock)
323  self%thread = -1
324 END SUBROUTINE destroy
325 
326 !===============================================================================
327 SUBROUTINE info (unit)
328  integer:: unit
329  real(8):: time
330  type(lock_t), pointer:: lock
331  !-----------------------------------------------------------------------------
332  if (.not.on) return
333  if (verbose > 0) then
334  lock => omp_lock%next
335  !$omp critical (lock_cr)
336  write (unit,'(1x,a)') ' id type wait wait/n hold hold/n n'
337  do while (associated(lock))
338  write (unit,'(i6,2x,a4,4f12.6,i12)') lock%id, lock%kind, &
339  lock%wait_time, 1d3*lock%wait_time/max(lock%n_hold,1_8), &
340  lock%hold_time, 1d3*lock%hold_time/max(lock%n_hold,1_8), &
341  lock%n_hold
342  lock%wait_time = 0.0_8
343  lock%hold_time = 0.0_8
344  lock%n_hold = 0_8
345  lock => lock%next
346  end do
347  !$omp end critical (lock_cr)
348  end if
349  !$omp atomic read
350  time = wait_time
351  write (unit,'(a,f10.3)') ' total lock waiting time =', time
352  !$omp atomic write
353  wait_time = 0d0
354 END SUBROUTINE info
355 
356 !===============================================================================
357 END MODULE omp_lock_mod
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...
The lock module uses nested locks, to allow versatile use of locks, where a procedure may want to mak...