Octopus
debug.F90
Go to the documentation of this file.
1!! Copyright (C) 2016 X. Andrade
2!!
3!! This program is free software; you can redistribute it and/or modify
4!! it under the terms of the GNU General Public License as published by
5!! the Free Software Foundation; either version 2, or (at your option)
6!! any later version.
7!!
8!! This program is distributed in the hope that it will be useful,
9!! but WITHOUT ANY WARRANTY; without even the implied warranty of
10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11!! GNU General Public License for more details.
12!!
13!! You should have received a copy of the GNU General Public License
14!! along with this program; if not, write to the Free Software
15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16!! 02110-1301, USA.
17!!
18
19#include "global.h"
20
21module debug_oct_m
22 use global_oct_m
24 use mpi_oct_m
26 use loct_oct_m
27 use parser_oct_m
28
29 implicit none
30
31 private
32 public :: &
33 debug_t, &
34 debug_init, &
39 debug, &
41#ifndef NDEBUG
44#endif
46
47 type debug_t
48 private
49 logical, public :: info
50 logical, public :: trace
51 logical, public :: trace_term
52 logical, public :: trace_file
53 logical :: extra_checks
54 logical, public :: interaction_graph
55 logical, public :: interaction_graph_full
56 logical, public :: propagation_graph
57 logical, public :: instrument
58 integer :: bits
59 character(len=MAX_PATH_LEN), public :: instr_sub_name
60 integer, public :: instr_tool
61 end type debug_t
62
63 type(debug_t), save :: debug
64
66 integer, parameter :: unit_offset = 1000
67
68 interface
69 subroutine debug_verrou_start_instrumentation() bind(C)
71
72 subroutine debug_verrou_stop_instrumentation() bind(C)
74
75 subroutine debug_fenv_start_instrumentation() bind(C)
77
78 subroutine debug_fenv_stop_instrumentation() bind(C)
80 end interface
81
82contains
83
84 subroutine debug_init(this, namespace)
85 type(debug_t), intent(out) :: this
86 type(namespace_t), intent(in) :: namespace
87
88 character(len=256) :: node_hook
89 logical :: file_exists, mpi_debug_hook
90 integer :: sec, usec
91 type(block_t) :: blk
92 integer :: line
93
94 !%Variable Debug
95 !%Type flag
96 !%Default no
97 !%Section Execution::Debug
98 !%Description
99 !% This variable controls the amount of debugging information
100 !% generated by Octopus. You can use include more than one option
101 !% with the + operator.
102 !%Option no 0
103 !% (default) <tt>Octopus</tt> does not enter debug mode.
104 !%Option info 1
105 !% Octopus prints additional information to the terminal.
106 !%Option trace 2
107 !% Octopus generates a stack trace as it enters end exits
108 !% subroutines. This information is reported if Octopus stops with
109 !% an error.
110 !%Option trace_term 4
111 !% The trace is printed to the terminal as Octopus enters or exits subroutines. This slows down execution considerably.
112 !%Option trace_file 8
113 !% The trace is written to files in the <tt>debug</tt>
114 !% directory. For each node (when running in parallel) there is a file called
115 !% <tt>debug_trace.&lt;rank&gt;</tt>. Writing these files slows down the code by a huge factor and
116 !% it is usually only necessary for parallel runs.
117 !%Option extra_checks 16
118 !% This enables Octopus to perform some extra checks, to ensure
119 !% code correctness, that might be too costly for regular runs.
120 !%Option interaction_graph 32
121 !% Octopus generates a dot file containing the graph for a multisystem run.
122 !%Option interaction_graph_full 64
123 !% Octopus generates a dot file containing the graph for a multisystem run including ghost interactions.
124 !%Option propagation_graph 128
125 !% Octopus generates a file with information for the propagation diagram.
126 !%Option instrument 256
127 !% Octopus adds instrumentation to functions specified in an <tt>InstrumentFunctions</tt> block.
128 !%End
129 call parse_variable(namespace, 'Debug', option__debug__no, this%bits)
130
131 call from_bits(this)
132
133 !%Variable InstrumentFunctions
134 !%Type block
135 !%Section Execution::Debug
136 !%Description
137 !% This input options controls which routines are going to be instrumented
138 !% for the tools selected using the <tt>Debug=instrument</tt> option.
139 !%
140 !% <br>%<tt>InstrumentFunctions
141 !% <br>&nbsp;&nbsp;"function_name" | instrumentation_tool
142 !% <br>%</tt>
143 !%
144 !% Here is an example to better understand how this works:
145 !%
146 !% <br>%<tt>InstrumentFunctions
147 !% <br>&nbsp;&nbsp;"grid/grid.F90.grid_init_from_grid_stage_1" | verrou
148 !% <br>%</tt>
149 !%
150 !% NOTE: Currently only a single function can be instrumented!
151 !%
152 !% Available instrumentation tools:
153 !%Option verrou 1
154 !% Verrou helps you look for floating-point round-off errors.
155 !%Option fenv 2
156 !% Enable floating-point exceptions. Requires Octopus to be compiled against glibc.
157 !%End
158 if (parse_block(namespace, "InstrumentFunctions", blk) == 0) then
159 ! TODO: Allow instrumentation of more than a single function
160 if (parse_block_n(blk) .gt. 1) then
161 write(stderr,'(a)') "Only single function can be instrumented!"
162 call mpi_world%abort()
163 end if
165 do line = 0, parse_block_n(blk) - 1
166 call parse_block_string(blk, line, 0, this%instr_sub_name)
167 call parse_block_integer(blk, line, 1, this%instr_tool)
168 select case (this%instr_tool)
169 case (option__instrumentfunctions__verrou)
170 write(stderr,'(a)') "Instrumenting " // trim(this%instr_sub_name) // " for Verrou"
171#if !defined(HAVE_VERROU)
172 write(stderr,'(a)') "requires VERROU but that library was not linked."
173 call mpi_world%abort()
174#endif
175 case (option__instrumentfunctions__fenv)
176 write(stderr,'(a)') "Instrumenting " // trim(this%instr_sub_name) // " with floating-point exceptions"
177 case default
178 assert(.false.) ! Should not happen
179 end select
180 end do
181 call parse_block_end(blk)
182 end if
183
184 call mpi_debug_init(mpi_world%rank, this%info)
185
186 if (this%info) then
187 !%Variable MPIDebugHook
188 !%Type logical
189 !%Default no
190 !%Section Execution::Debug
191 !%Description
192 !% When debugging the code in parallel it is usually difficult to find the origin
193 !% of race conditions that appear in MPI communications. This variable introduces
194 !% a facility to control separate MPI processes. If set to yes, all nodes will
195 !% start up, but will get trapped in an endless loop. In every cycle of the loop
196 !% each node is sleeping for one second and is then checking if a file with the
197 !% name <tt>node_hook.xxx</tt> (where <tt>xxx</tt> denotes the node number) exists. A given node can
198 !% only be released from the loop if the corresponding file is created. This allows
199 !% to selectively run, <i>e.g.</i>, a compute node first followed by the master node. Or, by
200 !% reversing the file creation of the node hooks, to run the master first followed
201 !% by a compute node.
202 !%End
203 call parse_variable(global_namespace, 'MPIDebugHook', .false., mpi_debug_hook)
204 if (mpi_debug_hook) then
205 call loct_gettimeofday(sec, usec)
206 call epoch_time_diff(sec,usec)
207 write(stdout,'(a,i6,a,i6.6,20x,a)') '* I ',sec,'.',usec,' | MPI debug hook'
208
209 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, ' In debug hook'
210 write(node_hook,'(i3.3)') mpi_world%rank
211 file_exists = .false.
212
213 do while (.not. file_exists)
214 inquire(file='node_hook.'//node_hook, exist=file_exists)
215 call loct_nanosleep(1,0)
216 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, &
217 ' - still sleeping. To release me touch: node_hook.'//trim(node_hook)
218 end do
219
220 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, ' Leaving debug hook'
221 ! remove possible debug hooks
222 call loct_rm('node_hook.'//trim(node_hook))
223
224 call loct_gettimeofday(sec, usec)
225 call epoch_time_diff(sec,usec)
226 write(stdout,'(a,i6,a,i6.6,20x,a)') '* O ', sec, '.', usec,' | MPI debug hook'
227 end if
228 end if
229
230 end subroutine debug_init
231
232 !--------------------------------------------------
233
234 subroutine debug_enable(this)
235 type(debug_t), intent(inout) :: this
236
237 this%info = .true.
238 this%trace = .true.
239 this%trace_term = .true.
240 this%trace_file = .true.
241 this%interaction_graph = .true.
242 this%interaction_graph_full = .true.
243 this%propagation_graph = .true.
244
245 end subroutine debug_enable
246
247 !--------------------------------------------------
248
249 subroutine debug_disable(this)
250 type(debug_t), intent(inout) :: this
251
252 call from_bits(this)
253
254 end subroutine debug_disable
255
256 !--------------------------------------------------
257
258 subroutine debug_delete_trace()
259
260 integer :: iunit
261 character(len=6) :: filenum
262
263 iunit = mpi_world%rank + unit_offset
264 write(filenum, '(i6.6)') iunit - unit_offset
265 call loct_mkdir('debug')
266 call loct_rm('debug/debug_trace.node.'//filenum)
267
268 end subroutine debug_delete_trace
269
270 ! ---------------------------------------------------------
271
272 subroutine debug_open_trace(iunit)
273 integer, intent(out) :: iunit
274
275 character(len=6) :: filenum
276
277 iunit = mpi_world%rank + unit_offset
278 write(filenum, '(i6.6)') iunit - unit_offset
279 call loct_mkdir('debug')
280 open(iunit, file = 'debug/debug_trace.node.'//filenum, &
281 action='write', status='unknown', position='append')
282
283 end subroutine debug_open_trace
284
285 ! ---------------------------------------------------------
286
287 subroutine from_bits(this)
288 type(debug_t), intent(inout) :: this
289
290 this%info = (bitand(this%bits, option__debug__info) /= 0)
291 this%trace_term = (bitand(this%bits, option__debug__trace_term) /= 0)
292 this%trace_file = (bitand(this%bits, option__debug__trace_file) /= 0)
293 this%trace = (bitand(this%bits, option__debug__trace) /= 0) .or. this%trace_term .or. this%trace_file
294 this%extra_checks = (bitand(this%bits, option__debug__extra_checks) /= 0) .or. this%trace_term .or. this%trace_file
295 this%interaction_graph = (bitand(this%bits, option__debug__interaction_graph) /= 0)
296 this%interaction_graph_full = (bitand(this%bits, option__debug__interaction_graph_full) /= 0)
297 this%propagation_graph = (bitand(this%bits, option__debug__propagation_graph) /= 0)
298 this%instrument = (bitand(this%bits, option__debug__instrument) /= 0)
299
300 end subroutine from_bits
301
302
303 ! ---------------------------------------------------------
304 subroutine epoch_time_diff(sec, usec)
305 integer, intent(inout) :: sec
306 integer, intent(inout) :: usec
307
308 ! this is called by push/pop so there cannot be a push/pop in this routine
309
310 call time_diff(s_epoch_sec, s_epoch_usec, sec, usec)
311 end subroutine epoch_time_diff
312
313
314 ! ---------------------------------------------------------
317 subroutine time_diff(sec1, usec1, sec2, usec2)
318 integer, intent(in) :: sec1
319 integer, intent(in) :: usec1
320 integer, intent(inout) :: sec2
321 integer, intent(inout) :: usec2
322
323 ! this is called by push/pop so there cannot be a push/pop in this routine
324
325 ! Correct overflow.
326 if (usec2 - usec1 < 0) then
327 usec2 = 1000000 + usec2
328 if (sec2 >= sec1) then
329 sec2 = sec2 - 1
330 end if
331 end if
332
333 ! Replace values.
334 if (sec2 >= sec1) then
335 sec2 = sec2 - sec1
336 end if
337 usec2 = usec2 - usec1
338
339 end subroutine time_diff
340
341
342#ifndef NDEBUG
343 ! ---------------------------------------------------------
345 subroutine debug_push_sub(sub_name)
346 character(len=*), intent(in) :: sub_name
347
348 integer, parameter :: max_recursion_level = 50
349 integer iunit, sec, usec
350
351 if (debug%instrument) then
352 if (debug_clean_path(sub_name) == trim(debug%instr_sub_name)) then
353 select case (debug%instr_tool)
354 case (option__instrumentfunctions__verrou)
356 case (option__instrumentfunctions__fenv)
358 case default
359 assert(.false.) ! cannot happen
360 end select
361 end if
362 end if
363
364 if (.not. debug%trace) return
365
366 if (debug%trace_file .or. debug%trace_term) then
367 call loct_gettimeofday(sec, usec)
368 call epoch_time_diff(sec, usec)
369 end if
370
372 if (no_sub_stack >= max_recursion_level) then
373 sub_stack(max_recursion_level) = 'debug_push_sub'
374 write(stderr, '(a,i3,a)') 'Too many recursion levels in debug trace (max=', max_recursion_level, ')'
375 call mpi_world%abort()
376 end if
377
378 sub_stack(no_sub_stack) = trim(debug_clean_path(sub_name))
380
381 if (debug%trace_file) then
383 call push_sub_write(iunit)
384 ! close file to ensure flushing
385 close(iunit)
386 end if
387
388 if (debug%trace_term .and. mpi_world%is_root()) then
389 ! write to stderr if we are node 0
390 call push_sub_write(stderr)
391 end if
392
393 contains
394
395 subroutine push_sub_write(iunit_out)
396 integer, intent(in) :: iunit_out
397
398 integer :: ii
399 character(len=1000) :: tmpstr
400
401 write(tmpstr,'(a,i6,a,i6.6,f20.6,i8,a)') "* I ", &
402 sec, '.', usec, &
403 loct_clock(), &
404 loct_get_memory_usage() / 1024, " | "
405 do ii = no_sub_stack - 1, 1, -1
406 write(tmpstr, '(2a)') trim(tmpstr), "..|"
407 end do
408 write(tmpstr, '(2a)') trim(tmpstr), trim(debug_clean_path(sub_name))
409 write(iunit_out, '(a)') trim(tmpstr)
410
411 end subroutine push_sub_write
413 end subroutine debug_push_sub
414
415 ! ---------------------------------------------------------
417 subroutine debug_pop_sub(sub_name)
418 character(len=*), intent(in) :: sub_name
419
420 character(len=80) :: sub_name_short
421 integer iunit, sec, usec
422
423 if (debug%instrument) then
424 if (debug_clean_path(sub_name) == trim(debug%instr_sub_name)) then
425 select case (debug%instr_tool)
426 case (option__instrumentfunctions__verrou)
428 case (option__instrumentfunctions__fenv)
430 case default
431 assert(.false.) ! cannot happen
432 end select
433 end if
434 end if
435
436 if (.not. debug%trace) return
437
438 call loct_gettimeofday(sec, usec)
439 call epoch_time_diff(sec, usec)
441 if (no_sub_stack <= 0) then
442 no_sub_stack = 1
443 sub_stack(1) = 'pop_sub'
444 write(stderr, '(a)') 'Too few recursion levels in debug trace'
445 call mpi_world%abort()
446 end if
447
448 ! the name might be truncated in sub_stack, so we copy to a string
449 ! of the same size
450 sub_name_short = trim(debug_clean_path(sub_name))
451
452 if (sub_name_short /= sub_stack(no_sub_stack)) then
453 write(stderr, '(a)') 'Wrong sub name on pop_sub :'
454 write(stderr, '(2a)') ' got : ', sub_name_short
455 write(stderr, '(2a)') ' expected : ', sub_stack(no_sub_stack)
456 call mpi_world%abort()
457 end if
458
459 if (debug%trace_file) then
460 call debug_open_trace(iunit)
461 call pop_sub_write(iunit)
462 ! close file to ensure flushing
463 close(iunit)
464 end if
465
466 if (debug%trace_term .and. mpi_world%is_root()) then
467 ! write to stderr if we are node 0
468 call pop_sub_write(stderr)
469 end if
470
472
473 contains
474
475 subroutine pop_sub_write(iunit_out)
476 integer, intent(in) :: iunit_out
477
478 integer :: ii
479 character(len=1000) :: tmpstr
480
481 write(tmpstr,'(a,i6,a,i6.6,f20.6,i8, a)') "* O ", &
482 sec, '.', usec, &
484 loct_get_memory_usage() / 1024, " | "
485 do ii = no_sub_stack - 1, 1, -1
486 write(tmpstr,'(2a)') trim(tmpstr), "..|"
487 end do
488 write(tmpstr,'(2a)') trim(tmpstr), trim(sub_stack(no_sub_stack))
489
490 write(iunit_out, '(a)') trim(tmpstr)
491
492 end subroutine pop_sub_write
493
494 end subroutine debug_pop_sub
495#endif
496
497 ! -----------------------------------------------------------
499 character(len=MAX_PATH_LEN) function debug_clean_path(filename) result(clean_path)
500 character(len=*), intent(in) :: filename
501
502 integer :: pos
503
504 pos = index(filename, 'src/', back = .true.)
505 if (pos == 0) then
506 ! 'src/' does not occur
507 clean_path = filename
508 else
509 ! remove 'src/'
510 clean_path = filename(pos+4:)
511 end if
513 end function debug_clean_path
514
515end module debug_oct_m
516
517!! Local Variables:
518!! mode: f90
519!! coding: utf-8
520!! End:
subroutine pop_sub_write(iunit_out)
Definition: debug.F90:571
subroutine push_sub_write(iunit_out)
Definition: debug.F90:491
Define which routines can be seen from the outside.
Definition: loct.F90:149
character(len=max_path_len) function, public debug_clean_path(filename)
Prune a filename path to only include subdirectories of the "src" directory.
Definition: debug.F90:595
subroutine, public debug_enable(this)
Definition: debug.F90:330
type(debug_t), save, public debug
Definition: debug.F90:158
subroutine, public debug_pop_sub(sub_name)
Pop a routine from the debug trace.
Definition: debug.F90:513
subroutine, public debug_open_trace(iunit)
Definition: debug.F90:368
subroutine, public epoch_time_diff(sec, usec)
Definition: debug.F90:400
subroutine from_bits(this)
Definition: debug.F90:383
subroutine, public debug_init(this, namespace)
Definition: debug.F90:180
subroutine, public debug_disable(this)
Definition: debug.F90:345
subroutine time_diff(sec1, usec1, sec2, usec2)
Computes t2 <- t2-t1. sec1,2 and usec1,2 are seconds,microseconds of t1,2.
Definition: debug.F90:413
subroutine, public debug_push_sub(sub_name)
Push a routine to the debug trace.
Definition: debug.F90:441
subroutine, public debug_delete_trace()
Definition: debug.F90:354
integer, public s_epoch_sec
global epoch time (time at startup)
Definition: global.F90:249
integer, public no_sub_stack
Definition: global.F90:254
real(real64), dimension(50), public time_stack
Definition: global.F90:253
character(len=80), dimension(50), public sub_stack
The stack.
Definition: global.F90:252
integer, public s_epoch_usec
Definition: global.F90:249
subroutine, public loct_rm(name)
Definition: loct.F90:307
subroutine, public loct_mkdir(name)
Definition: loct.F90:293
subroutine, public mpi_debug_init(rank, info)
Definition: mpi_debug.F90:196
type(mpi_grp_t), public mpi_world
Definition: mpi.F90:272
type(namespace_t), public global_namespace
Definition: namespace.F90:134
subroutine, public parse_block_string(blk, l, c, res, convert_to_c)
Definition: parser.F90:810
integer function, public parse_block(namespace, name, blk, check_varinfo_)
Definition: parser.F90:615
int true(void)