1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 %;
  7 /* ******************************************************
  8    *                                                    *
  9    *                                                    *
 10    * Copyright (c) 1972 by Massachusetts Institute of   *
 11    * Technology and Honeywell Information Systems, Inc. *
 12    *                                                    *
 13    *                                                    *
 14    ****************************************************** */
 15 
 16 /* originally coded by Steve Webber  May 1971.
 17    Modified by Steve Webber March 1974.
 18    Modified by John Gintell June 1974 for MCR  598
 19    Modified by John Gintell May 1975 for MCR's 957 and 970,
 20    Modified by John Gintell Oct 1975 for MCR 1342.
 21    Modified 760506 by PG for MCRs 1832 (fix bug in link fault printing) and 1833 (add ctl args).
 22    Modified Feb 1979 by John Gintell for  MCR 3663 (fix bug in print_trace_entry).
 23    Modified June 1981 by J. Bongiovanni to fix bug in -from processing
 24    Modified January 1982 by J. Bongiovanni for extended page fault type
 25 */
 26 
 27 page_trace: pgt: proc;
 28 
 29 /* automatic */
 30 
 31 dcl (header, longsw, print_pagefaults, marker_seen, stop_at_marker, count_given) bit (1) aligned,
 32     (dp, eptr, tp) ptr,
 33      ring_no fixed bin (3),
 34     (from, to) char (4) aligned,
 35      string char (20),
 36     offset fixed bin(18),
 37     (next, total, count, i, tc, long, fmtx, start_index) fixed bin,
 38      code fixed bin (35),
 39      data_area (1024) fixed bin,
 40     (time, type, seg_no, page_no, hcscnt) fixed bin,
 41      dirname char (168),
 42      ename char (32),
 43      proc_name char (32),
 44      proc_offset fixed bin (18),
 45      proc_segno fixed bin,
 46      comp_name char (8),
 47      entry_name char (32),
 48      switch_ptr ptr,                                        /* pointer to I/O switch */
 49      ftime float bin;
 50 
 51 /* based */
 52 
 53 dcl  based_char_4 char (4) aligned based,
 54      packedptr ptr based unal,
 55      targ char (tc) based (tp);
 56 
 57 
 58 /* internal static */
 59 
 60 dcl  output_format (0:11) char (50) varying aligned internal static options (constant) initial (
 61      "^20x^s^8.2f^3o^6o^5o^2x^s^a",                         /* 0 - short page fault */
 62      "^20x^s^8.2f^3o^6o^5o^2x^a>^a",                        /* 1 - long page fault */
 63      "^20a^8.2f^3x^s^6o^5x^s^2x^s^a",                       /* 2 - short (seg/bound) fault */
 64      "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a",                      /* 3 - long (seg/bound) fault */
 65      "^20a^8.2f^3x^s^6o^5x^s^2x^s^a$^a",                    /* 4 - short end linkage fault */
 66      "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a$^a",                   /* 5 - long end linkage fault */
 67      "^20a^8.2f^3x^s^6x^s^5x^s^2x^s^a",                     /* 6 - signal generated/user marker/etc */
 68      "^20a^8.2f",                                           /* 7 - make ptr/signal restarted/reschedule */
 69      "^20a^8.2f^3x^s^6o^5x^s^2x^s^a^a|^o",                  /* 8 - short start linkage fault */
 70      "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a^a|^o",                 /* 9 - long  start linkage fault */
 71      "^20x^s^8.2f^3x^s^6o^5o^2x^s^a",                       /* 10 - short page fault (extended) */
 72      "^20x^s^8.2f^3x^s^6o^5o^2x^a>^a^2s^/^46xby ^a|^o");    /* 11 - long page fault(extended)  */
 73 
 74 /* external static */
 75 
 76 dcl (active_all_rings_data_$hcscnt fixed bin,
 77      iox_$user_output ptr) external static;
 78 dcl  error_table_$badopt fixed bin (35) external static;
 79 dcl  error_table_$inconsistent fixed bin (35) external static;
 80 
 81 /* entries */
 82 
 83 dcl  hcs_$get_page_trace entry (ptr),
 84      hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*), fixed bin(35)),
 85      ioa_$ioa_switch entry options (variable),
 86      iox_$look_iocb entry (char (*), ptr, fixed bin (35)),
 87      get_entry_name_ entry (ptr, char (*), fixed bin, char (8), fixed bin (35)),
 88      com_err_ entry options (variable),
 89      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
 90      cu_$arg_count entry returns (fixed bin),
 91      interpret_bind_map_ entry (ptr, char(*), fixed bin(18), fixed bin(35)),
 92      ring0_get_$name entry (char(*), char(*), ptr, fixed bin (35));
 93 
 94 /* builtins */
 95 
 96 dcl (addr, baseno, baseptr, rel, binary, convert, substr, unspec) builtin;
 97 
 98 /* conditions */
 99 
100 dcl (conversion, not_in_read_bracket) condition;
101 
102 /* include files */
103 
104 %include sys_trace;
105 %include trace_types;
106 
107 /* ^L */
108 
109           dp = addr (data_area);                            /* get a pointer to buffer */
110           call hcs_$get_page_trace (dp);                    /* copy the trace information from ring 0 */
111 
112           longsw = ""b;                                     /* default is short mode */
113           count_given = ""b;
114           print_pagefaults = "1"b;                          /* default is to print page faults */
115           stop_at_marker = ""b;                             /* default is to print until end */
116           from = "";                                        /* default is no from argument */
117           to = "";                                          /* default is no to argument */
118           marker_seen = "0"b;                               /* haven't seen from marker yet. */
119 
120           hcscnt = active_all_rings_data_$hcscnt;
121           switch_ptr = iox_$user_output;
122 
123           next =  dp -> trace.next_free;                    /* get index to last used cell */
124           count, total = dp -> trace.last_available;        /* get size of trace array */
125 
126           do i = 1 to cu_$arg_count ();
127                call cu_$arg_ptr (i, tp, tc, code);          /* pick up the argument (if it's given) */
128                if targ = "-long" | targ = "-lg" then longsw = "1"b;
129                else if targ = "-no_header" | targ = "-nhe" then header = "0"b;
130                else if targ = "-output_switch" | targ = "-os" then do;
131                     i = i + 1;
132                     call cu_$arg_ptr (i, tp, tc, code);
133                     if code ^= 0 then do;
134                          call com_err_ (code, "page_trace", "-output_switch must be followed by a switch name.");
135                          return;
136                     end;
137                     call iox_$look_iocb (targ, switch_ptr, code);
138                     if code ^= 0 then do;
139                          call com_err_ (code, "page_trace", "Switch ^a not found.", targ);
140                          return;
141                     end;
142                end;
143                else if targ = "-from" | targ = "-fm" then do;
144                     i = i + 1;
145                     call cu_$arg_ptr (i, tp, tc, code);
146                     if code ^= 0 then do;
147                          call com_err_ (code, "page_trace", "-from must be followed by a character string.");
148                          return;
149                     end;
150                     from = targ;
151                end;
152                else if targ = "-to" then do;
153                     i = i + 1;
154                     call cu_$arg_ptr (i, tp, tc, code);
155                     if code ^= 0 then do;
156                          call com_err_ (code, "page_trace", "-to must be followed by a character string.");
157                          return;
158                     end;
159                     stop_at_marker = "1"b;
160                     to = targ;
161                end;
162                else if targ = "-npf" | targ = "-no_pagefaults" then print_pagefaults = ""b;
163                else if substr (targ, 1, 1) = "-" then do;   /* mispelled ctl arg */
164                     call com_err_ (error_table_$badopt, "page_trace", "^a", targ);
165                     return;
166                end;
167                else do;
168                     count_given = "1"b;
169                     on conversion go to bad_count;          /* trap bad numbers */
170                     count = convert (count, targ);          /* convert args to binary */
171                     revert conversion;                      /* make handler go away */
172                     if count <= 0 | count > total then do;
173 bad_count:
174                          call com_err_ (0, "page_trace", "Invalid count value given, ^a", targ);
175                          return;
176                     end;
177                end;
178           end;
179 
180           if count_given & (from ^= "" | to ^= "") then do;
181                call com_err_ (error_table_$inconsistent, "page_trace",
182                     "count and ^[-from ^]^[-to ^]", (from ^= ""), (to ^= ""));
183                return;
184           end;
185 
186           if header
187           then call ioa_$ioa_switch (switch_ptr, "^/^-^-Elapsed^/     Trace Type    Time (ms) Ring Segno Page^-Segment^/");
188 
189           if count > next
190           then start_index = total + next - count + 1;
191           else start_index = next - count + 1;
192 
193           if from ^= ""                                     /* -from specified? */
194           then if count > next
195                then do i = start_index to total, 1 to next;
196                     trace_ptr = addr (dp -> trace.data (i));
197                     if trace_ptr -> page_trace_entry.type = marker_type
198                     then if trace_ptr -> based_char_4 = from
199                          then do;
200                               start_index = i;
201                               go to scan;
202                          end;
203                     count = count - 1;
204                end;
205                else do i = start_index to next;
206                     trace_ptr = addr (dp -> trace.data (i));
207                     if trace_ptr -> page_trace_entry.type = marker_type
208                     then if trace_ptr -> based_char_4 = from
209                          then do;
210                               start_index = i;
211                               go to scan;
212                          end;
213                     count = count - 1;
214                end;
215 
216 scan:
217           if count > next
218           then do i = start_index to total, 1 to next;      /* wrap-around ? */
219                trace_ptr = addr (dp -> trace.data (i));     /* get pointer to entry */
220                call output;
221                if stop_at_marker
222                then if trace_ptr -> page_trace_entry.type = marker_type
223                     then if trace_ptr -> based_char_4 = to
224                          then go to done;
225           end;
226           else do i = start_index to next;                  /* no wrap-around, just scan the last 'count' */
227                trace_ptr = addr (dp -> trace.data (i));     /* get pointer to entry */
228                call output;
229                if stop_at_marker
230                then if trace_ptr -> page_trace_entry.type = marker_type
231                     then if trace_ptr -> based_char_4 = to
232                          then go to done;
233           end;
234 
235 done:
236           call ioa_$ioa_switch (switch_ptr, "");
237           return;
238 ^L
239 output:   proc;
240 
241                if unspec (trace_ptr -> page_trace_entry) = "0"b
242                     then return;
243 
244                type = trace_ptr -> page_trace_entry.type;
245                time = trace_ptr -> page_trace_entry.time;
246                if time = 65535 then ftime = 0e0;
247                else ftime = time*64/1e3;                    /* convert the time to milli-seconds */
248 
249                if type = page_fault_type | type = seg_fault_start
250                     | type = seg_fault_end
251                     | type = boundfault_start | type = boundfault_end
252                     then seg_no = trace_ptr -> page_trace_entry.segment_number;
253 
254                else if type = extended_page_fault_type
255                     then seg_no = binary (trace_ptr -> extended_page_trace_entry.tsr_segno_1
256                     || trace_ptr -> extended_page_trace_entry.tsr_segno_2, 12);
257 
258                else if type = linkage_fault_end
259                then do;
260                     eptr = trace_ptr -> packedptr;
261                     call get_entry_name_ (eptr, entry_name, seg_no, comp_name, code);
262                     if entry_name = "" then entry_name = "0";
263                end;
264 
265                else if type = linkage_fault_start then do;
266                     eptr = trace_ptr->packedptr;
267                     offset = binary(rel(eptr),18);
268                     entry_name = "";
269                     on not_in_read_bracket goto ISGATE;
270                     call interpret_bind_map_(eptr,entry_name,offset,code );
271                     revert not_in_read_bracket;
272 ISGATE:
273                     if entry_name ^= "" then entry_name = ": " || entry_name;
274                     seg_no = binary(baseno(eptr),18);
275                end;
276 
277                else seg_no = -1;
278 
279                if seg_no ^= -1 then call get_segment_name (seg_no, dirname, ename);
280                else dirname, ename = "";
281 
282 
283 
284                page_no = 0;
285                ring_no = 0;
286                proc_name = "";
287                proc_segno = 0;
288                proc_offset = 0;
289                long = binary (longsw, 1);
290 
291                if type = page_fault_type then do;
292                     if ^print_pagefaults then return;
293                     page_no = trace_ptr -> page_trace_entry.page_number;
294                     ring_no = trace_ptr -> page_trace_entry.ring;
295                     fmtx = 0 + long;
296                end;
297                else if type = extended_page_fault_type then do;
298                     page_no = trace_ptr -> extended_page_trace_entry.tsr_pageno;
299                     proc_segno = trace_ptr -> extended_page_trace_entry.psr_segno;
300                     proc_offset = trace_ptr -> extended_page_trace_entry.psr_offset;
301                     call get_segment_name (proc_segno, (""), proc_name);
302                     fmtx = 10 + long;
303                end;
304                else if type = seg_fault_start then do;
305                     string = "SEG-FAULT-START";
306                     fmtx = 2 + long;
307                end;
308                else if type = seg_fault_end then do;
309                     string = "SEG-FAULT-END";
310                     fmtx = 2 + long;
311                end;
312                else if type = boundfault_start then do;
313                     string = "BOUND-FAULT-START";
314                     fmtx = 2 + long;
315                end;
316                else if type = boundfault_end then do;
317                     string = "BOUND-FAULT-END";
318                     fmtx = 2 + long;
319                end;
320                else if type = linkage_fault_start then do;
321                     if seg_no = 0 then do;
322                          string = "MAKE-PTR-CALL";
323                          fmtx = 7;
324                     end;
325                     else do;
326                          string = "LINKAGE FAULT BY";
327                          fmtx = 8 + long;
328                     end;
329                end;
330                else if type = linkage_fault_end then do;
331                     string = "RESOLVED LINK TO";
332                     fmtx = 4 + long;
333                end;
334                else if type = signaller_type then do;
335                     string = "SIGNAL GENERATED";
336                     fmtx = 6;
337                     ename = trace_ptr -> based_char_4;
338                end;
339                else if type = restart_fault_type then do;
340                     string = "SIGNAL RESTARTED";
341                     fmtx = 7;
342                end;
343                else if type = reschedule_type then do;
344                     string = "RESCHEDULING";
345                     fmtx = 7;
346                end;
347                else if type = marker_type then do;
348                     string = "USER MARKER";
349                     fmtx = 6;
350                     ename = trace_ptr -> based_char_4;
351                end;
352                else do;
353                     string = "UNRECOGNIZABLE ENTRY";
354                     fmtx = 6;
355                     ename = trace_ptr -> based_char_4;
356                end;
357 
358                call ioa_$ioa_switch (switch_ptr, output_format (fmtx),
359                     string, ftime, ring_no, seg_no, page_no, dirname, ename,
360                     entry_name, offset, proc_name, proc_offset);
361 
362                return;
363           end;
364 %page;
365 print_trace_entry: entry (a_trace_ptr, a_switch_ptr, a_longsw);
366 
367 /*        internal interface provided for cumulative_page_trace.
368    *      It interprets and prints one entry from the system trace array.
369 */
370 
371 dcl  a_trace_ptr ptr;                                       /* pointer to entry in system trace array */
372 dcl  a_switch_ptr ptr;                                      /* switch_ptr onto which output is placed */
373 dcl  a_longsw bit (1) aligned;                              /* set to "1"b if -long was given */
374 
375           hcscnt = active_all_rings_data_$hcscnt;
376           switch_ptr = a_switch_ptr;
377           trace_ptr = a_trace_ptr;
378           longsw = a_longsw;
379           print_pagefaults = "1"b;
380 
381           call output;
382 
383           return;
384 
385 %page;
386 get_segment_name:
387 proc (segment_number, dname, ename);
388 
389 dcl segment_number fixed bin;
390 dcl dname char (*);
391 dcl ename char (*);
392 
393 dcl temp fixed bin;
394 
395                if segment_number >= active_all_rings_data_$hcscnt then do; /* if user initiated segment ... */
396                     call hcs_$fs_get_path_name (baseptr (segment_number), dname, temp, ename, code);
397                     if code ^= 0 then do;
398                          dname = "";
399                          ename = "*** unknown segment ***";
400                     end;
401                     else if ^longsw then if ename = "" then ename = ">"; /* root */
402                end;
403                else do;
404                     call ring0_get_$name (dname, ename, baseptr (segment_number), code);
405                     dname = "";
406                end;
407 
408 end get_segment_name;
409 
410 end page_trace;