|
| 1 | +!> |
| 2 | +!! @file |
| 3 | +!! @brief Contains module m_trace |
| 4 | + |
| 5 | +!> @brief Simple runtime call tracing helpers. |
| 6 | +module m_trace |
| 7 | + |
| 8 | + use iso_fortran_env, only: output_unit |
| 9 | + |
| 10 | + implicit none |
| 11 | + |
| 12 | + private |
| 13 | + public :: s_trace_enter, s_trace_call, s_trace_global_call, s_trace_point_begin, s_trace_point_end |
| 14 | + |
| 15 | + logical, private :: trace_initialized = .false. |
| 16 | + logical, private :: trace_enabled = .false. |
| 17 | + logical, private :: trace_point_enabled = .false. |
| 18 | + logical, private :: trace_point_middle = .false. |
| 19 | + integer, private :: trace_j = 0 |
| 20 | + integer, private :: trace_k = 0 |
| 21 | + integer, private :: trace_l = 0 |
| 22 | + integer, private :: trace_point_depth = 0 |
| 23 | + character(len=64), private :: trace_point_vars = '' |
| 24 | + |
| 25 | + interface |
| 26 | + subroutine c_trace_point_begin() bind(C, name="mfc_trace_point_begin") |
| 27 | + |
| 28 | + end subroutine c_trace_point_begin |
| 29 | + |
| 30 | + subroutine c_trace_point_end() bind(C, name="mfc_trace_point_end") |
| 31 | + |
| 32 | + end subroutine c_trace_point_end |
| 33 | + end interface |
| 34 | + |
| 35 | +contains |
| 36 | + |
| 37 | + !> Initialize trace settings from environment variables. |
| 38 | + subroutine s_initialize_trace |
| 39 | + |
| 40 | + character(len=64) :: env_value |
| 41 | + integer :: env_len |
| 42 | + integer :: first_comma |
| 43 | + integer :: second_comma |
| 44 | + integer :: read_status |
| 45 | + |
| 46 | + if (trace_initialized) return |
| 47 | + |
| 48 | + call get_environment_variable('MFC_TRACE', env_value, length=env_len) |
| 49 | + trace_enabled = env_len > 0 .and. trim(env_value) /= '0' |
| 50 | + |
| 51 | + call get_environment_variable('MFC_TRACE_POINT', env_value, length=env_len) |
| 52 | + if (env_len > 0) then |
| 53 | + if (trim(env_value(:env_len)) == 'middle') then |
| 54 | + trace_point_enabled = .true. |
| 55 | + trace_point_middle = .true. |
| 56 | + else |
| 57 | + first_comma = index(env_value, ',') |
| 58 | + second_comma = 0 |
| 59 | + if (first_comma > 0) second_comma = index(env_value(first_comma + 1:), ',') |
| 60 | + if (second_comma > 0) second_comma = second_comma + first_comma |
| 61 | + |
| 62 | + if (first_comma > 0 .and. second_comma > first_comma) then |
| 63 | + read (env_value(:first_comma - 1), *, iostat=read_status) trace_j |
| 64 | + trace_point_enabled = read_status == 0 |
| 65 | + read (env_value(first_comma + 1:second_comma - 1), *, iostat=read_status) trace_k |
| 66 | + trace_point_enabled = trace_point_enabled .and. read_status == 0 |
| 67 | + read (env_value(second_comma + 1:env_len), *, iostat=read_status) trace_l |
| 68 | + trace_point_enabled = trace_point_enabled .and. read_status == 0 |
| 69 | + end if |
| 70 | + end if |
| 71 | + end if |
| 72 | + |
| 73 | + call get_environment_variable('MFC_TRACE_POINT_VARS', env_value, length=env_len) |
| 74 | + if (env_len > 0) trace_point_vars = trim(env_value(:env_len)) |
| 75 | + |
| 76 | + trace_initialized = .true. |
| 77 | + |
| 78 | + end subroutine s_initialize_trace |
| 79 | + |
| 80 | + !> Emit a live call-trace line when MFC_TRACE is enabled. |
| 81 | + subroutine s_trace_enter(name) |
| 82 | + |
| 83 | + character(len=*), intent(in) :: name |
| 84 | + |
| 85 | + call s_initialize_trace() |
| 86 | + |
| 87 | + if (.not. trace_enabled) return |
| 88 | + if (trace_point_enabled .and. trace_point_depth <= 0) return |
| 89 | + |
| 90 | + write (output_unit, '(A,A)') 'TRACE ', trim(name) |
| 91 | + call flush (output_unit) |
| 92 | + |
| 93 | + end subroutine s_trace_enter |
| 94 | + |
| 95 | + !> Emit a live call-site trace when the current trace scope is active. |
| 96 | + subroutine s_trace_call(name) |
| 97 | + |
| 98 | + character(len=*), intent(in) :: name |
| 99 | + |
| 100 | + call s_initialize_trace() |
| 101 | + |
| 102 | + if (.not. trace_enabled) return |
| 103 | + if (trace_point_enabled .and. trace_point_depth <= 0) return |
| 104 | + |
| 105 | + write (output_unit, '(A,A)') 'TRACE ', trim(name) |
| 106 | + call flush (output_unit) |
| 107 | + |
| 108 | + end subroutine s_trace_call |
| 109 | + |
| 110 | + !> Emit a call-site trace even when point tracing has not entered a cell loop yet. |
| 111 | + subroutine s_trace_global_call(name) |
| 112 | + |
| 113 | + character(len=*), intent(in) :: name |
| 114 | + |
| 115 | + call s_initialize_trace() |
| 116 | + |
| 117 | + if (.not. trace_enabled) return |
| 118 | + |
| 119 | + write (output_unit, '(A,A)') 'TRACE ', trim(name) |
| 120 | + call flush (output_unit) |
| 121 | + |
| 122 | + end subroutine s_trace_global_call |
| 123 | + |
| 124 | + !> Enable nested routine-entry tracing while a call at MFC_TRACE_POINT executes. |
| 125 | + subroutine s_trace_point_begin(j, k, l, vars, mid_j, mid_k, mid_l) |
| 126 | + |
| 127 | + integer, intent(in) :: j |
| 128 | + integer, intent(in) :: k |
| 129 | + integer, intent(in) :: l |
| 130 | + character(len=*), intent(in) :: vars |
| 131 | + integer, intent(in) :: mid_j |
| 132 | + integer, intent(in) :: mid_k |
| 133 | + integer, intent(in) :: mid_l |
| 134 | + integer :: target_j |
| 135 | + integer :: target_k |
| 136 | + integer :: target_l |
| 137 | + |
| 138 | + call s_initialize_trace() |
| 139 | + |
| 140 | + if (.not. trace_enabled) return |
| 141 | + if (.not. trace_point_enabled) return |
| 142 | + if (len_trim(trace_point_vars) > 0 .and. trim(trace_point_vars) /= 'any') then |
| 143 | + if (trim(vars) /= trim(trace_point_vars)) return |
| 144 | + end if |
| 145 | + if (trace_point_middle) then |
| 146 | + target_j = mid_j |
| 147 | + target_k = mid_k |
| 148 | + target_l = mid_l |
| 149 | + else |
| 150 | + target_j = trace_j |
| 151 | + target_k = trace_k |
| 152 | + target_l = trace_l |
| 153 | + end if |
| 154 | + |
| 155 | + if (j /= target_j .or. k /= target_k .or. l /= target_l) return |
| 156 | + |
| 157 | + trace_point_depth = trace_point_depth + 1 |
| 158 | + call c_trace_point_begin() |
| 159 | + |
| 160 | + end subroutine s_trace_point_begin |
| 161 | + |
| 162 | + !> Disable nested point tracing after a grid-point call returns. |
| 163 | + subroutine s_trace_point_end |
| 164 | + |
| 165 | + call s_initialize_trace() |
| 166 | + |
| 167 | + if (.not. trace_enabled) return |
| 168 | + if (.not. trace_point_enabled) return |
| 169 | + if (trace_point_depth > 0) then |
| 170 | + call c_trace_point_end() |
| 171 | + trace_point_depth = trace_point_depth - 1 |
| 172 | + end if |
| 173 | + |
| 174 | + end subroutine s_trace_point_end |
| 175 | + |
| 176 | +end module m_trace |
0 commit comments